v class="head">

Theory Utils

theory Utils
  imports Regular_Tree_Relations.Term_Context
    Regular_Tree_Relations.FSet_Utils
begin

subsection ‹Misc›

definition "funas_trs ℛ = ⋃ ((λ (s, t). funas_term s ∪ funas_term t) ` ℛ)"

fun linear_term :: "('f, 'v) term ⇒ bool" where
  "linear_term (Var _) = True" |
  "linear_term (Fun _ ts) = (is_partition (map vars_term ts) ∧ (∀t∈set ts. linear_term t))"

fun vars_term_list :: "('f, 'v) term ⇒ 'v list" where
  "vars_term_list (Var x) = [x]" |
  "vars_term_list (Fun _ ts) = concat (map vars_term_list ts)"

fun varposs :: "('f, 'v) term ⇒ pos set" where
  "varposs (Var x) = {[]}" |
  "varposs (Fun f ts) = (⋃i<length ts. {i # p | p. p ∈ varposs (ts ! i)})"

abbreviation "poss_args f ts ≡ map2 (λ i t. map ((#) i) (f t)) ([0 ..< length ts]) ts"

fun varposs_list :: "('f, 'v) term ⇒ pos list" where
  "varposs_list (Var x) = [[]]" |
  "varposs_list (Fun f ts) = concat (poss_args varposs_list ts)"

fun concat_index_split where
  "concat_index_split (o_idx, i_idx) (x # xs) =
     (if i_idx < length x
      then (o_idx, i_idx)
      else concat_index_split (Suc o_idx, i_idx - length x) xs)"

inductive_set trancl_list for ℛ where
  base[intro, Pure.intro] : "length xs = length ys ⟹
      (∀ i < length ys. (xs ! i, ys ! i) ∈ ℛ) ⟹ (xs, ys) ∈ trancl_list ℛ"
| list_trancl [Pure.intro]: "(xs, ys) ∈ trancl_list ℛ ⟹ i < length ys ⟹ (ys ! i, z) ∈ ℛ ⟹
    (xs, ys[i := z]) ∈ trancl_list ℛ"


lemma sorted_append_bigger:
  "sorted xs ⟹  ∀x ∈ set xs. x ≤ y ⟹ sorted (xs @ [y])"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then have s: "sorted xs" by (cases xs) simp_all
  from Cons have a: "∀x∈set xs. x ≤ y" by simp
  from Cons(1)[OF s a] Cons(2-) show ?case by (cases xs) simp_all
qed

lemma find_SomeD:
  "List.find P xs = Some x ⟹ P x"
  "List.find P xs = Some x ⟹ x∈set xs"
  by (auto simp add: find_Some_iff)

lemma sum_list_replicate_length' [simp]:
  "sum_list (replicate n (Suc 0)) = n"
  by (induct n) simp_all

lemma arg_subteq [simp]:
  assumes "t ∈ set ts" shows "Fun f ts ⊵ t"
  using assms by auto

lemma finite_funas_term: "finite (funas_term s)"
  by (induct s) auto

lemma finite_funas_trs:
  "finite ℛ ⟹ finite (funas_trs ℛ)"
  by (induct rule: finite.induct) (auto simp: finite_funas_term funas_trs_def)

fun subterms where
  "subterms (Var x) = {Var x}"|
  "subterms (Fun f ts) = {Fun f ts} ∪ (⋃ (subterms ` set ts))"

lemma finite_subterms_fun: "finite (subterms s)"
  by (induct s) auto

lemma subterms_supteq_conv: "t ∈ subterms s ⟷ s ⊵ t"
  by (induct s) (auto elim: supteq.cases)

lemma set_all_subteq_subterms:
  "subterms s = {t. s ⊵ t}"
  using subterms_supteq_conv by auto

lemma finite_subterms: "finite {t. s ⊵ t}"
  unfolding set_all_subteq_subterms[symmetric]
  by (simp add: finite_subterms_fun)

lemma finite_strict_subterms: "finite {t. s ⊳ t}"
  by (intro finite_subset[OF _ finite_subterms]) auto

lemma finite_UN_I2:
  "finite A ⟹ (∀ B ∈ A. finite B) ⟹ finite (⋃ A)"
  by blast

lemma root_substerms_funas_term:
  "the ` (root ` (subterms s) - {None}) = funas_term s" (is "?Ls = ?Rs")
proof -
  thm subterms.induct
  {fix x assume "x ∈ ?Ls" then have "x ∈ ?Rs"
    proof (induct s arbitrary: x)
      case (Fun f ts)
      then show ?case
        by auto (metis DiffI Fun.hyps imageI option.distinct(1) singletonD) 
    qed auto}
  moreover
  {fix g assume "g ∈ ?Rs" then have "g ∈ ?Ls"
    proof (induct s arbitrary: g)
      case (Fun f ts)
      from Fun(2) consider "g = (f, length ts)" | "∃ t ∈ set ts. g ∈ funas_term t"
        by (force simp: in_set_conv_nth)
      then show ?case
      proof cases
        case 1 then show ?thesis
          by (auto simp: image_iff intro: bexI[of _ "Some (f, length ts)"])
      next
        case 2
        then obtain t where wit: "t ∈ set ts" "g ∈ funas_term t" by blast
        have "g ∈ the ` (root ` subterms t - {None})" using Fun(1)[OF wit] .
        then show ?thesis using wit(1)
          by (auto simp: image_iff)
      qed
    qed auto}
  ultimately show ?thesis by auto
qed

lemma root_substerms_funas_term_set:
  "the ` (root ` ⋃ (subterms ` R) - {None}) = ⋃ (funas_term ` R)"
  using root_substerms_funas_term
  by auto (smt DiffE DiffI UN_I image_iff)


lemma subst_merge:
  assumes part: "is_partition (map vars_term ts)"
  shows "∃σ. ∀i<length ts. ∀x∈vars_term (ts ! i). σ x = τ i x"
proof -
  let ?τ = "map τ [0 ..< length ts]"
  let ?σ = "fun_merge ?τ (map vars_term ts)"
  show ?thesis
    by (rule exI[of _ ?σ], intro allI impI ballI,
      insert fun_merge_part[OF part, of _ _ ?τ], auto)
qed


lemma rel_comp_empty_trancl_simp: "R O R = {} ⟹ R+ = R"
  by (metis O_assoc relcomp_empty2 sup_bot_right trancl_unfold trancl_unfold_right)

lemma choice_nat:
  assumes "∀i<n. ∃x. P x i"
  shows "∃f. ∀x<n. P (f x) x" using assms 
proof -
  from assms have "∀ i. ∃ x. i < n ⟶ P x i" by simp
  from choice[OF this] show ?thesis by auto
qed


lemma subseteq_set_conv_nth:
  "(∀ i < length ss. ss ! i ∈ T) ⟷ set ss ⊆ T"
  by (metis in_set_conv_nth subset_code(1))

lemma singelton_trancl [simp]: "{a}+ = {a}"
  using tranclD tranclD2 by fastforce 

context
includes fset.lifting
begin
lemmas frelcomp_empty_ftrancl_simp = rel_comp_empty_trancl_simp [Transfer.transferred]
lemmas in_fset_idx = in_set_idx [Transfer.transferred]
lemmas fsubseteq_fset_conv_nth = subseteq_set_conv_nth [Transfer.transferred]
lemmas singelton_ftrancl [simp] = singelton_trancl [Transfer.transferred]
end

lemma set_take_nth:
  assumes "x ∈ set (take i xs)"
  shows "∃ j < length xs. j < i ∧ xs ! j = x" using assms
  by (metis in_set_conv_nth length_take min_less_iff_conj nth_take)

lemma nth_sum_listI:
  assumes "length xs = length ys"
    and "∀ i < length xs. xs ! i = ys ! i"
  shows "sum_list xs = sum_list ys"
  using assms nth_equalityI by blast

lemma concat_nth_length:
  "i < length uss ⟹ j < length (uss ! i) ⟹
    sum_list (map length (take i uss)) + j < length (concat uss)"
by (induct uss arbitrary: i j) (simp, case_tac i, auto)

lemma sum_list_1_E [elim]:
  assumes "sum_list xs = Suc 0"
  obtains i where "i < length xs" "xs ! i = Suc 0" "∀ j < length xs. j ≠ i ⟶ xs ! j = 0"
proof -
  have "∃ i < length xs. xs ! i = Suc 0 ∧ (∀ j < length xs. j ≠ i ⟶ xs ! j = 0)" using assms
  proof (induct xs)
    case (Cons a xs) show ?case
    proof (cases a)
      case [simp]: 0
      obtain i where "i < length xs" "xs ! i = Suc 0" "(∀ j < length xs. j ≠ i ⟶ xs ! j = 0)"
        using Cons by auto
      then show ?thesis using less_Suc_eq_0_disj
        by (intro exI[of _ "Suc i"]) auto
    next
      case (Suc nat) then show ?thesis using Cons by auto
    qed
  qed auto
  then show " (⋀i. i < length xs ⟹ xs ! i = Suc 0 ⟹ ∀j<length xs. j ≠ i ⟶ xs ! j = 0 ⟹ thesis) ⟹ thesis"
    by blast
qed


lemma nth_equalityE:
  "xs = ys ⟹ (length xs = length ys ⟹ (⋀i. i < length xs ⟹ xs ! i = ys ! i) ⟹ P) ⟹ P"
  by simp

lemma map_cons_presv_distinct:
  "distinct t ⟹ distinct (map ((#) i) t)"
  by (simp add: distinct_conv_nth)

lemma concat_nth_nthI:
  assumes "length ss = length ts" "∀ i < length ts. length (ss ! i) = length (ts ! i)"
    and "∀ i < length ts. ∀ j < length (ts ! i). P (ss ! i ! j) (ts ! i ! j)"
  shows "∀ i < length (concat ts). P (concat ss ! i) (concat ts ! i)"
  using assms by (metis nth_concat_two_lists)


lemma last_nthI:
  assumes "i < length ts" "¬ i < length ts - Suc 0"
  shows "ts ! i = last ts" using assms
  by (induct ts arbitrary: i)
    (auto, metis last_conv_nth length_0_conv less_antisym nth_Cons')

(* induction scheme for transitive closures of lists *)
lemma trancl_list_appendI [simp, intro]:
  "(xs, ys) ∈ trancl_list ℛ ⟹ (x, y) ∈ ℛ ⟹ (x # xs, y # ys) ∈ trancl_list ℛ"
proof (induct rule: trancl_list.induct)
  case (base xs ys)
  then show ?case using less_Suc_eq_0_disj
    by (intro trancl_list.base) auto
next
  case (list_trancl xs ys i z)
  from list_trancl(3) have *: "y # ys[i := z] = (y # ys)[Suc i := z]" by auto
  show ?case using list_trancl unfolding *
    by (intro trancl_list.list_trancl) auto
qed

lemma trancl_list_append_tranclI [intro]:
  "(x, y) ∈ ℛ+ ⟹ (xs, ys) ∈ trancl_list ℛ ⟹ (x # xs, y # ys) ∈ trancl_list ℛ"
proof (induct rule: trancl.induct)
  case (trancl_into_trancl a b c)
  then have "(a # xs, b # ys) ∈ trancl_list ℛ" by auto
  from trancl_list.list_trancl[OF this, of 0 c]
  show ?case using trancl_into_trancl(3)
    by auto
qed auto

lemma trancl_list_conv:
  "(xs, ys) ∈ trancl_list ℛ ⟷ length xs = length ys ∧ (∀ i < length ys. (xs ! i, ys ! i) ∈ ℛ+)" (is "?Ls ⟷ ?Rs")
proof
  assume "?Ls" then show ?Rs
  proof (induct)
    case (list_trancl xs ys i z)
    then show ?case
      by auto (metis nth_list_update trancl.trancl_into_trancl)
  qed auto
next
  assume ?Rs then show ?Ls
  proof (induct ys arbitrary: xs)
    case Nil
    then show ?case by (cases xs) auto
  next
    case (Cons y ys)
    from Cons(2) obtain x xs' where *: "xs = x # xs'" and
      inv: "(x, y) ∈ ℛ+"
      by (cases xs) auto
    show ?case using Cons(1)[of "tl xs"] Cons(2) unfolding *
      by (intro trancl_list_append_tranclI[OF inv]) force
  qed
qed

lemma trancl_list_induct [consumes 2, case_names base step]:
  assumes "length ss = length ts" "∀ i < length ts. (ss ! i, ts ! i) ∈ ℛ+"
   and "⋀xs ys. length xs = length ys ⟹ ∀ i < length ys. (xs ! i, ys ! i) ∈ ℛ ⟹ P xs ys"
   and "⋀xs ys i z. length xs = length ys ⟹ ∀ i < length ys. (xs ! i, ys ! i) ∈ ℛ+ ⟹ P xs ys
      ⟹ i < length ys ⟹ (ys ! i, z) ∈ ℛ ⟹ P xs (ys[i := z])"
 shows "P ss ts" using assms
  by (intro trancl_list.induct[of ss ts ℛ P]) (auto simp: trancl_list_conv)


lemma swap_trancl:
  "(prod.swap ` R)+ = prod.swap ` (R+)"
proof -
  have [simp]: "prod.swap ` X = X¯" for X by auto
  show ?thesis by (simp add: trancl_converse)
qed

lemma swap_rtrancl:
  "(prod.swap ` R)* = prod.swap ` (R*)"
proof -
  have [simp]: "prod.swap ` X = X¯" for X by auto
  show ?thesis by (simp add: rtrancl_converse)
qed

lemma Restr_simps:
  "R ⊆ X × X ⟹ Restr (R+) X = R+"
  "R ⊆ X × X ⟹ Restr Id X O R = R"
  "R ⊆ X × X ⟹ R O Restr Id X = R"
  "R ⊆ X × X ⟹ S ⊆ X × X ⟹ Restr (R O S) X = R O S"
  "R ⊆ X × X ⟹ R+ ⊆ X × X"
  subgoal using trancl_mono_set[of R "X × X"] by (auto simp: trancl_full_on)
  subgoal by auto
  subgoal by auto
  subgoal by auto
  subgoal using trancl_subset_Sigma .
  done

lemma Restr_tracl_comp_simps:
  "ℛ ⊆ X × X ⟹ ℒ ⊆ X × X ⟹ ℒ+ O ℛ ⊆ X × X"
  "ℛ ⊆ X × X ⟹ ℒ ⊆ X × X ⟹ ℒ O ℛ+ ⊆ X × X"
  "ℛ ⊆ X × X ⟹ ℒ ⊆ X × X ⟹ ℒ+ O ℛ O ℒ+ ⊆ X × X"
  by (auto dest: subsetD[OF Restr_simps(5)[of ℒ]] subsetD[OF Restr_simps(5)[of ℛ]])


text ‹Conversions of the Nth function between lists and a spliting of the list into lists of lists›

lemma concat_index_split_mono_first_arg:
  "i < length (concat xs) ⟹ o_idx ≤ fst (concat_index_split (o_idx, i) xs)"
  by (induct xs arbitrary: o_idx i) (auto, metis Suc_leD add_diff_inverse_nat nat_add_left_cancel_less)

lemma concat_index_split_sound_fst_arg_aux:
  "i < length (concat xs) ⟹ fst (concat_index_split (o_idx, i) xs) < length xs + o_idx"
  by (induct xs arbitrary: o_idx i) (auto, metis add_Suc_right add_diff_inverse_nat nat_add_left_cancel_less)

lemma concat_index_split_sound_fst_arg:
  "i < length (concat xs) ⟹ fst (concat_index_split (0, i) xs) < length xs"
  using concat_index_split_sound_fst_arg_aux[of i xs 0] by auto

lemma concat_index_split_sound_snd_arg_aux:
  assumes "i < length (concat xs)"
  shows "snd (concat_index_split (n, i) xs) < length (xs ! (fst (concat_index_split (n, i) xs) - n))" using assms
proof (induct xs arbitrary: i n)
  case (Cons x xs)
  show ?case proof (cases "i < length x")
    case False then have size: "i - length x < length (concat xs)"
      using Cons(2) False by auto
    obtain k j where [simp]: "concat_index_split (Suc n, i - length x) xs = (k, j)"
      using old.prod.exhaust by blast
    show ?thesis using False Cons(1)[OF size, of "Suc n"] concat_index_split_mono_first_arg[OF size, of "Suc n"]
      by (auto simp: nth_append)
  qed (auto simp add: nth_append) 
qed auto

lemma concat_index_split_sound_snd_arg:
  assumes "i < length (concat xs)"
  shows "snd (concat_index_split (0, i) xs) < length (xs ! fst (concat_index_split (0, i) xs))"
  using concat_index_split_sound_snd_arg_aux[OF assms, of 0] by auto

lemma reconstr_1d_concat_index_split:
  assumes "i < length (concat xs)"
  shows "i = (λ (m, j). sum_list (map length (take (m - n) xs)) + j) (concat_index_split (n, i) xs)" using assms
proof (induct xs arbitrary: i n)
  case (Cons x xs) show ?case
  proof (cases "i < length x")
    case False
    obtain m k where res: "concat_index_split (Suc n, i - length x) xs = (m, k)"
      using prod_decode_aux.cases by blast
    then have unf_ind: "concat_index_split (n, i) (x # xs) = concat_index_split (Suc n, i - length x) xs" and
      size: "i - length x < length (concat xs)" using Cons(2) False by auto
    have "Suc n ≤ m" using concat_index_split_mono_first_arg[OF size, of "Suc n"] by (auto simp: res)
    then have [simp]: "sum_list (map length (take (m - n) (x # xs))) = sum_list (map length (take (m - Suc n) xs)) + length x"
      by (simp add: take_Cons')
    show ?thesis using Cons(1)[OF size, of "Suc n"] False unfolding unf_ind res by auto
  qed auto
qed auto

lemma concat_index_split_larger_lists [simp]:
  assumes "i < length (concat xs)"
  shows "concat_index_split (n, i) (xs @ ys) = concat_index_split (n, i) xs" using assms
  by (induct xs arbitrary: ys n i) auto

lemma concat_index_split_split_sound_aux:
  assumes "i < length (concat xs)"
  shows "concat xs ! i = (λ (k, j). xs ! (k - n) ! j) (concat_index_split (n, i) xs)" using assms
proof (induct xs arbitrary: i n)
  case (Cons x xs)
  show ?case proof (cases "i < length x")
    case False then have size: "i - length x < length (concat xs)"
      using Cons(2) False by auto
    obtain k j where [simp]: "concat_index_split (Suc n, i - length x) xs = (k, j)"
      using prod_decode_aux.cases by blast
    show ?thesis using False Cons(1)[OF size, of "Suc n"]
      using concat_index_split_mono_first_arg[OF size, of "Suc n"]
      by (auto simp: nth_append)
  qed (auto simp add: nth_append) 
qed auto

lemma concat_index_split_sound:
  assumes "i < length (concat xs)"
  shows "concat xs ! i = (λ (k, j). xs ! k ! j) (concat_index_split (0, i) xs)"
  using concat_index_split_split_sound_aux[OF assms, of 0] by auto

lemma concat_index_split_sound_bounds:
  assumes "i < length (concat xs)" and "concat_index_split (0, i) xs = (m, n)"
  shows "m < length xs" "n < length (xs ! m)"
  using concat_index_split_sound_fst_arg[OF assms(1)] concat_index_split_sound_snd_arg[OF assms(1)]
  by (auto simp: assms(2))

lemma concat_index_split_less_length_concat:
  assumes "i < length (concat xs)" and "concat_index_split (0, i) xs = (m, n)"
  shows "i = sum_list (map length (take m xs)) + n" "m < length xs" "n < length (xs ! m)"
    "concat xs ! i = xs ! m ! n"
  using concat_index_split_sound[OF assms(1)] reconstr_1d_concat_index_split[OF assms(1), of 0]
  using concat_index_split_sound_fst_arg[OF assms(1)] concat_index_split_sound_snd_arg[OF assms(1)] assms(2)
  by auto

lemma nth_concat_split':
  assumes "i < length (concat xs)"
  obtains j k where "j < length xs" "k < length (xs ! j)" "concat xs ! i = xs ! j ! k" "i = sum_list (map length (take j xs)) + k"
  using concat_index_split_less_length_concat[OF assms]
  by (meson old.prod.exhaust)

lemma sum_list_split [dest!, consumes 1]:
  assumes "sum_list (map length (take i xs)) + j = sum_list (map length (take k xs)) + l"
   and "i < length xs" "k < length xs"
   and "j < length (xs ! i)" "l < length (xs ! k)"
 shows "i = k ∧ j = l" using assms
proof (induct xs rule: rev_induct)
  case (snoc x xs)
  then show ?case
    by (auto simp: nth_append split: if_splits)
       (metis concat_nth_length length_concat not_add_less1)+
qed auto

lemma concat_index_split_unique:
  assumes "i < length (concat xs)" and "length xs = length ys"
    and "∀ i < length xs. length (xs ! i) = length (ys ! i)"
  shows "concat_index_split (n, i) xs = concat_index_split (n, i) ys" using assms
proof (induct xs arbitrary: ys n i)
  case (Cons x xs) note IH = this show ?case
  proof (cases ys)
    case Nil then show ?thesis using Cons(3) by auto
  next
    case [simp]: (Cons y ys')
    have [simp]: "length y = length x" using IH(4) by force
    have [simp]: "¬ i < length x ⟹ i - length x < length (concat xs)" using IH(2) by auto
    have [simp]: "i < length ys' ⟹ length (xs ! i) = length (ys' ! i)" for i using IH(3, 4)
      by (auto simp: All_less_Suc) (metis IH(4) Suc_less_eq length_Cons Cons nth_Cons_Suc)
    show ?thesis using IH(2-) IH(1)[of "i - length x" ys' "Suc n"] by auto
  qed
qed auto

lemma set_vars_term_list [simp]:
  "set (vars_term_list t) = vars_term t"
  by (induct t) simp_all

lemma vars_term_list_empty_ground [simp]:
  "vars_term_list t = [] ⟷ ground t"
  by (induct t) auto

lemma varposs_imp_poss:
  assumes "p ∈ varposs t"
  shows "p ∈ poss t"
  using assms by (induct t arbitrary: p) auto

lemma vaposs_list_fun:
  assumes "p ∈ set (varposs_list (Fun f ts))"
  obtains i ps where "i < length ts" "p = i # ps"
  using assms set_zip_leftD by fastforce

lemma varposs_list_distinct:
  "distinct (varposs_list t)"
proof (induct t)
  case (Fun f ts)
  then show ?case proof (induct ts rule: rev_induct)
    case (snoc x xs)
    then have "distinct (varposs_list (Fun f xs))" "distinct (varposs_list x)" by auto
    then show ?case using snoc by (auto simp add: map_cons_presv_distinct dest: set_zip_leftD)
  qed auto
qed auto

lemma varposs_append:
  "varposs (Fun f (ts @ [t])) = varposs (Fun f ts) ∪ ((#) (length ts)) ` varposs t"
  by (auto simp: nth_append split: if_splits)

lemma varposs_eq_varposs_list:
  "set (varposs_list t) = varposs t"
proof (induct t)
  case (Fun f ts)
  then show ?case proof (induct ts rule: rev_induct)
    case (snoc x xs)
    then have "varposs (Fun f xs) = set (varposs_list (Fun f xs))"
      "varposs x = set (varposs_list x)" by auto
    then show ?case using snoc unfolding varposs_append
      by auto
  qed auto
qed auto

lemma varposs_list_var_terms_length:
  "length (varposs_list t) = length (vars_term_list t)"
  by (induct t) (auto simp: vars_term_list.simps intro: eq_length_concat_nth)

lemma vars_term_list_nth:
  assumes "i < length (vars_term_list (Fun f ts))"
    and "concat_index_split (0, i) (map vars_term_list ts) = (k, j)"
  shows "k < length ts ∧ j < length (vars_term_list (ts ! k)) ∧
    vars_term_list (Fun f ts) ! i = map vars_term_list ts ! k ! j ∧
    i = sum_list (map length (map vars_term_list (take k ts))) + j"
  using assms concat_index_split_less_length_concat[of i "map vars_term_list ts" k j]
  by (auto simp: vars_term_list.simps comp_def take_map) 

lemma varposs_list_nth:
  assumes "i < length (varposs_list (Fun f ts))"
     and "concat_index_split (0, i) (poss_args varposs_list ts) = (k, j)"
  shows "k < length ts ∧ j < length (varposs_list (ts ! k)) ∧
    varposs_list (Fun f ts) ! i = k # (map varposs_list ts) ! k ! j ∧
    i = sum_list (map length (map varposs_list (take k ts))) + j"
  using assms concat_index_split_less_length_concat[of i "poss_args varposs_list ts" k j]
  by (auto simp: comp_def take_map intro: nth_sum_listI)

lemma varposs_list_to_var_term_list:
  assumes "i < length (varposs_list t)"
  shows "the_Var (t |_ (varposs_list t ! i)) = (vars_term_list t) ! i" using assms
proof (induct t arbitrary: i)
  case (Fun f ts)
  have "concat_index_split (0, i) (poss_args varposs_list ts) = concat_index_split (0, i) (map vars_term_list ts)"
    using Fun(2) concat_index_split_unique[of i "poss_args varposs_list ts" "map vars_term_list ts" 0]
    using varposs_list_var_terms_length[of "ts ! i" for i]
    by (auto simp: vars_term_list.simps)
  then obtain k j where "concat_index_split (0, i) (poss_args varposs_list ts) = (k, j)"
    "concat_index_split (0, i) (map vars_term_list ts) = (k, j)" by fastforce
  from varposs_list_nth[OF Fun(2) this(1)] vars_term_list_nth[OF _ this(2)]
  show ?case using Fun(2) Fun(1)[OF nth_mem] varposs_list_var_terms_length[of "Fun f ts"] by auto
qed (auto simp: vars_term_list.simps)

end

Theory Multihole_Context

(*
Author:  Bertram Felgenhauer <bertram.felgenhauer@uibk.ac.at> (2015)
Author:  Christian Sternagel <c.sternagel@gmail.com> (2013-2016)
Author:  Martin Avanzini <martin.avanzini@uibk.ac.at> (2014)
Author:  René Thiemann <rene.thiemann@uibk.ac.at> (2013-2015)
Author:  Julian Nagele <julian.nagele@uibk.ac.at> (2016)
License: LGPL (see file COPYING.LESSER)
*)

section ‹Preliminaries›
subsection ‹Multihole Contexts›

theory Multihole_Context
imports 
  Utils
begin

unbundle lattice_syntax

subsubsection ‹Partitioning lists into chunks of given length›

lemma concat_nth:
  assumes "m < length xs" and "n < length (xs ! m)"
    and "i = sum_list (map length (take m xs)) + n"
  shows "concat xs ! i = xs ! m ! n"
using assms
proof (induct xs arbitrary: m n i)
  case (Cons x xs)
  show ?case
  proof (cases m)
    case 0
    then show ?thesis using Cons by (simp add: nth_append)
  next
    case (Suc k)
    with Cons(1) [of k n "i - length x"] and Cons(2-)
      show ?thesis by (simp_all add: nth_append)
  qed
qed simp

lemma sum_list_take_eq:
  fixes xs :: "nat list"
  shows "k < i ⟹ i < length xs ⟹ sum_list (take i xs) =
    sum_list (take k xs) + xs ! k + sum_list (take (i - Suc k) (drop (Suc k) xs))"
  by (subst id_take_nth_drop [of k]) (auto simp: min_def drop_take)

fun partition_by where
  "partition_by xs [] = []" |
  "partition_by xs (y#ys) = take y xs # partition_by (drop y xs) ys"

lemma partition_by_map0_append [simp]:
  "partition_by xs (map (λx. 0) ys @ zs) = replicate (length ys) [] @ partition_by xs zs"
by (induct ys) simp_all

lemma concat_partition_by [simp]:
  "sum_list ys = length xs ⟹ concat (partition_by xs ys) = xs"
by (induct ys arbitrary: xs) simp_all

definition partition_by_idx where
  "partition_by_idx l ys i j = partition_by [0..<l] ys ! i ! j"

lemma partition_by_nth_nth_old:
  assumes "i < length (partition_by xs ys)"
    and "j < length (partition_by xs ys ! i)"
    and "sum_list ys = length xs"
  shows "partition_by xs ys ! i ! j = xs ! (sum_list (map length (take i (partition_by xs ys))) + j)"
  using concat_nth [OF assms(1, 2) refl]
  unfolding concat_partition_by [OF assms(3)] by simp

lemma map_map_partition_by:
  "map (map f) (partition_by xs ys) = partition_by (map f xs) ys"
by (induct ys arbitrary: xs) (auto simp: take_map drop_map)

lemma length_partition_by [simp]:
  "length (partition_by xs ys) = length ys"
  by (induct ys arbitrary: xs) simp_all

lemma partition_by_Nil [simp]:
  "partition_by [] ys = replicate (length ys) []"
  by (induct ys) simp_all

lemma partition_by_concat_id [simp]:
  assumes "length xss = length ys"
    and "⋀i. i < length ys ⟹ length (xss ! i) = ys ! i"
  shows "partition_by (concat xss) ys = xss"
  using assms by (induct ys arbitrary: xss) (simp, case_tac xss, simp, fastforce)

lemma partition_by_nth:
  "i < length ys ⟹ partition_by xs ys ! i = take (ys ! i) (drop (sum_list (take i ys)) xs)"
  by (induct ys arbitrary: xs i) (simp, case_tac i, simp_all add: ac_simps)

lemma partition_by_nth_less:
  assumes "k < i" and "i < length zs"
    and "length xs = sum_list (take i zs) + j"
  shows "partition_by (xs @ y # ys) zs ! k = take (zs ! k) (drop (sum_list (take k zs)) xs)"
proof -
  have "partition_by (xs @ y # ys) zs ! k =
    take (zs ! k) (drop (sum_list (take k zs)) (xs @ y # ys))"
    using assms by (auto simp: partition_by_nth)
  moreover have "zs ! k + sum_list (take k zs) ≤ length xs"
    using assms by (simp add: sum_list_take_eq)
  ultimately show ?thesis by simp
qed

lemma partition_by_nth_greater:
  assumes "i < k" and "k < length zs" and "j < zs ! i"
    and "length xs = sum_list (take i zs) + j"
  shows "partition_by (xs @ y # ys) zs ! k =
    take (zs ! k) (drop (sum_list (take k zs) - 1) (xs @ ys))"
proof -
  have "partition_by (xs @ y # ys) zs ! k =
    take (zs ! k) (drop (sum_list (take k zs)) (xs @ y # ys))"
    using assms by (auto simp: partition_by_nth)
  moreover have "sum_list (take k zs) > length xs"
    using assms by (auto simp: sum_list_take_eq)
  ultimately show ?thesis by (auto) (metis Suc_diff_Suc drop_Suc_Cons)
qed

lemma length_partition_by_nth:
  "sum_list ys = length xs ⟹ i < length ys ⟹ length (partition_by xs ys ! i) = ys ! i"
by (induct ys arbitrary: xs i; case_tac i) auto

lemma partition_by_nth_nth_elem:
  assumes "sum_list ys = length xs" "i < length ys" "j < ys ! i"
  shows "partition_by xs ys ! i ! j ∈ set xs"
proof -
  from assms have "j < length (partition_by xs ys ! i)" by (simp only: length_partition_by_nth)
  then have "partition_by xs ys ! i ! j ∈ set (partition_by xs ys ! i)" by auto
  with assms(2) have "partition_by xs ys ! i ! j ∈ set (concat (partition_by xs ys))" by auto
  then show ?thesis using assms by simp
qed

lemma partition_by_nth_nth:
  assumes "sum_list ys = length xs" "i < length ys" "j < ys ! i"
  shows "partition_by xs ys ! i ! j = xs ! partition_by_idx (length xs) ys i j"
        "partition_by_idx (length xs) ys i j < length xs"
unfolding partition_by_idx_def
proof -
  let ?n = "partition_by [0..<length xs] ys ! i ! j"
  show "?n < length xs"
    using partition_by_nth_nth_elem[OF _ assms(2,3), of "[0..<length xs]"] assms(1) by simp
  have li: "i < length (partition_by [0..<length xs] ys)" using assms(2) by simp
  have lj: "j < length (partition_by [0..<length xs] ys ! i)"
    using assms by (simp add: length_partition_by_nth)
  have "partition_by (map ((!) xs) [0..<length xs]) ys ! i ! j = xs ! ?n"
    by (simp only: map_map_partition_by[symmetric] nth_map[OF li] nth_map[OF lj])
  then show "partition_by xs ys ! i ! j = xs ! ?n" by (simp add: map_nth)
qed
  
lemma map_length_partition_by [simp]:
  "sum_list ys = length xs ⟹ map length (partition_by xs ys) = ys"
  by (intro nth_equalityI, auto simp: length_partition_by_nth)

lemma map_partition_by_nth [simp]:
  "i < length ys ⟹ map f (partition_by xs ys ! i) = partition_by (map f xs) ys ! i"
  by (induct ys arbitrary: i xs) (simp, case_tac i, simp_all add: take_map drop_map)

lemma sum_list_partition_by [simp]:
  "sum_list ys = length xs ⟹
    sum_list (map (λx. sum_list (map f x)) (partition_by xs ys)) = sum_list (map f xs)"
  by (induct ys arbitrary: xs) (simp_all, metis append_take_drop_id sum_list_append map_append)

lemma partition_by_map_conv:
  "partition_by xs ys = map (λi. take (ys ! i) (drop (sum_list (take i ys)) xs)) [0 ..< length ys]"
  by (rule nth_equalityI) (simp_all add: partition_by_nth)

lemma UN_set_partition_by_map:
  "sum_list ys = length xs ⟹ (⋃x∈set (partition_by (map f xs) ys). ⋃ (set x)) = ⋃(set (map f xs))"
  by (induct ys arbitrary: xs)
     (simp_all add: drop_map take_map, metis UN_Un append_take_drop_id set_append)

lemma UN_set_partition_by:
  "sum_list ys = length xs ⟹ (⋃zs ∈ set (partition_by xs ys). ⋃x ∈ set zs. f x) = (⋃x ∈ set xs. f x)"
  by (induct ys arbitrary: xs) (simp_all, metis UN_Un append_take_drop_id set_append)

lemma Ball_atLeast0LessThan_partition_by_conv:
  "(∀i∈{0..<length ys}. ∀x∈set (partition_by xs ys ! i). P x) =
    (∀x ∈ ⋃(set (map set (partition_by xs ys))). P x)"
  by auto (metis atLeast0LessThan in_set_conv_nth length_partition_by lessThan_iff)

lemma Ball_set_partition_by:
  "sum_list ys = length xs ⟹
  (∀x ∈ set (partition_by xs ys). ∀y ∈ set x. P y) = (∀x ∈ set xs. P x)"
proof (induct ys arbitrary: xs)
  case (Cons y ys)
  then show ?case
    apply (subst (2) append_take_drop_id [of y xs, symmetric])
    apply (simp only: set_append)
    apply auto
  done
qed simp

lemma partition_by_append2:
  "partition_by xs (ys @ zs) = partition_by (take (sum_list ys) xs) ys @ partition_by (drop (sum_list ys) xs) zs"
by (induct ys arbitrary: xs) (auto simp: drop_take ac_simps split: split_min)

lemma partition_by_concat2:
  "partition_by xs (concat ys) =
   concat (map (λi . partition_by (partition_by xs (map sum_list ys) ! i) (ys ! i)) [0..<length ys])"
proof -
  have *: "map (λi . partition_by (partition_by xs (map sum_list ys) ! i) (ys ! i)) [0..<length ys] =
    map (λ(x,y). partition_by x y) (zip (partition_by xs (map sum_list ys)) ys)"
    using zip_nth_conv[of "partition_by xs (map sum_list ys)" ys] by auto
  show ?thesis unfolding * by (induct ys arbitrary: xs) (auto simp: partition_by_append2)
qed

lemma partition_by_partition_by:
  "length xs = sum_list (map sum_list ys) ⟹
   partition_by (partition_by xs (concat ys)) (map length ys) =
   map (λi. partition_by (partition_by xs (map sum_list ys) ! i) (ys ! i)) [0..<length ys]"
by (auto simp: partition_by_concat2 intro: partition_by_concat_id)

subsubsection ‹Multihole contexts definition and functionalities›
datatype ('f, vars_mctxt : 'v) mctxt = MVar 'v | MHole | MFun 'f "('f, 'v) mctxt list"

subsubsection ‹Conversions from and to multihole contexts›

primrec mctxt_of_term :: "('f, 'v) term ⇒ ('f, 'v) mctxt" where
  "mctxt_of_term (Var x) = MVar x" |
  "mctxt_of_term (Fun f ts) = MFun f (map mctxt_of_term ts)"

primrec term_of_mctxt :: "('f, 'v) mctxt ⇒ ('f, 'v) term" where
  "term_of_mctxt (MVar x) = Var x" |
  "term_of_mctxt (MFun f Cs) = Fun f (map term_of_mctxt Cs)"

fun num_holes :: "('f, 'v) mctxt ⇒ nat" where
  "num_holes (MVar _) = 0" |
  "num_holes MHole = 1" |
  "num_holes (MFun _ ctxts) = sum_list (map num_holes ctxts)"

fun ground_mctxt :: "('f, 'v) mctxt ⇒ bool" where 
  "ground_mctxt (MVar _) = False" |
  "ground_mctxt MHole = True" |
  "ground_mctxt (MFun f Cs) = Ball (set Cs) ground_mctxt"

fun map_mctxt :: "('f ⇒ 'g) ⇒ ('f, 'v) mctxt ⇒ ('g, 'v) mctxt"
where
  "map_mctxt _ (MVar x) = (MVar x)" |
  "map_mctxt _ (MHole) = MHole" |
  "map_mctxt fg (MFun f Cs) = MFun (fg f) (map (map_mctxt fg) Cs)"

abbreviation "partition_holes xs Cs ≡ partition_by xs (map num_holes Cs)"
abbreviation "partition_holes_idx l Cs ≡ partition_by_idx l (map num_holes Cs)"

fun fill_holes :: "('f, 'v) mctxt ⇒ ('f, 'v) term list ⇒ ('f, 'v) term" where
  "fill_holes (MVar x) _ = Var x" |
  "fill_holes MHole [t] = t" |
  "fill_holes (MFun f cs) ts = Fun f (map (λ i. fill_holes (cs ! i)
    (partition_holes ts cs ! i)) [0 ..< length cs])"

fun fill_holes_mctxt :: "('f, 'v) mctxt ⇒ ('f, 'v) mctxt list ⇒ ('f, 'v) mctxt" where
  "fill_holes_mctxt (MVar x) _ = MVar x" |
  "fill_holes_mctxt MHole [] = MHole" |
  "fill_holes_mctxt MHole [t] = t" |
  "fill_holes_mctxt (MFun f cs) ts = (MFun f (map (λ i. fill_holes_mctxt (cs ! i) 
    (partition_holes ts cs ! i)) [0 ..< length cs]))"


fun unfill_holes :: "('f, 'v) mctxt ⇒ ('f, 'v) term ⇒ ('f, 'v) term list" where
  "unfill_holes MHole t = [t]"
| "unfill_holes (MVar w) (Var v) = (if v = w then [] else undefined)"
| "unfill_holes (MFun g Cs) (Fun f ts) = (if f = g ∧ length ts = length Cs then
    concat (map (λi. unfill_holes (Cs ! i) (ts ! i)) [0..<length ts]) else undefined)"

fun funas_mctxt where
  "funas_mctxt (MFun f Cs) = {(f, length Cs)} ∪ ⋃(funas_mctxt ` set Cs)" |
  "funas_mctxt _ = {}"

fun split_vars :: "('f, 'v) term ⇒ (('f, 'v) mctxt × 'v list)" where
  "split_vars (Var x) = (MHole, [x])" |
  "split_vars (Fun f ts) = (MFun f (map (fst ∘ split_vars) ts), concat (map (snd ∘ split_vars) ts))"


fun hole_poss_list :: "('f, 'v) mctxt ⇒ pos list" where
  "hole_poss_list (MVar x) = []" |
  "hole_poss_list MHole = [[]]" |
  "hole_poss_list (MFun f cs) = concat (poss_args hole_poss_list cs)"

fun map_vars_mctxt :: "('v ⇒ 'w) ⇒ ('f, 'v) mctxt ⇒ ('f, 'w) mctxt"
where
  "map_vars_mctxt vw MHole = MHole" |
  "map_vars_mctxt vw (MVar v) = (MVar (vw v))" |
  "map_vars_mctxt vw (MFun f Cs) = MFun f (map (map_vars_mctxt vw) Cs)"

inductive eq_fill :: "('f, 'v) term ⇒ ('f, 'v) mctxt × ('f, 'v) term list ⇒ bool" ("(_/ =f _)" [51, 51] 50)
where
  eqfI [intro]: "t = fill_holes D ss ⟹ num_holes D = length ss ⟹ t =f (D, ss)"

subsubsection ‹Semilattice Structures›

instantiation mctxt :: (type, type) inf

begin

fun inf_mctxt :: "('a, 'b) mctxt ⇒ ('a, 'b) mctxt ⇒ ('a, 'b) mctxt"
where
  "MHole ⊓ D = MHole" |
  "C ⊓ MHole = MHole" |
  "MVar x ⊓ MVar y = (if x = y then MVar x else MHole)" |
  "MFun f Cs ⊓ MFun g Ds =
    (if f = g ∧ length Cs = length Ds then MFun f (map (case_prod (⊓)) (zip Cs Ds))
    else MHole)" |
  "C ⊓ D = MHole"

instance ..

end

lemma inf_mctxt_idem [simp]:
  fixes C :: "('f, 'v) mctxt"
  shows "C ⊓ C = C"
  by (induct C) (auto simp: zip_same_conv_map intro: map_idI)

lemma inf_mctxt_MHole2 [simp]:
  "C ⊓ MHole = MHole"
  by (induct C) simp_all

lemma inf_mctxt_comm [ac_simps]:
  "(C :: ('f, 'v) mctxt) ⊓ D = D ⊓ C"
  by (induct C D rule: inf_mctxt.induct) (fastforce simp: in_set_conv_nth intro!: nth_equalityI)+

lemma inf_mctxt_assoc [ac_simps]:
  fixes C :: "('f, 'v) mctxt"
  shows "C ⊓ D ⊓ E = C ⊓ (D ⊓ E)"
  apply (induct C D arbitrary: E rule: inf_mctxt.induct)
  apply (auto simp: )
  apply (case_tac E, auto)+
  apply (fastforce simp: in_set_conv_nth intro!: nth_equalityI)
  apply (case_tac E, auto)+
done

instantiation mctxt :: (type, type) order
begin

definition "(C :: ('a, 'b) mctxt) ≤ D ⟷ C ⊓ D = C"
definition "(C :: ('a, 'b) mctxt) < D ⟷ C ≤ D ∧ ¬ D ≤ C"

instance
  by (standard, simp_all add: less_eq_mctxt_def less_mctxt_def ac_simps, metis inf_mctxt_assoc)

end

inductive less_eq_mctxt' :: "('f, 'v) mctxt ⇒ ('f,'v) mctxt ⇒ bool" where
  "less_eq_mctxt' MHole u"
| "less_eq_mctxt' (MVar v) (MVar v)"
| "length cs = length ds ⟹ (⋀i. i < length cs ⟹ less_eq_mctxt' (cs ! i) (ds ! i)) ⟹ less_eq_mctxt' (MFun f cs) (MFun f ds)"


subsubsection ‹Lemmata›

lemma partition_holes_fill_holes_conv:
  "fill_holes (MFun f cs) ts =
    Fun f [fill_holes (cs ! i) (partition_holes ts cs ! i). i ← [0 ..< length cs]]"
  by (simp add: partition_by_nth take_map)

lemma partition_holes_fill_holes_mctxt_conv:
  "fill_holes_mctxt (MFun f Cs) ts =
    MFun f [fill_holes_mctxt (Cs ! i) (partition_holes ts Cs ! i). i ← [0 ..< length Cs]]"
  by (simp add: partition_by_nth take_map)

text ‹The following induction scheme provides the @{term MFun} case with the list argument split
  according to the argument contexts. This feature is quite delicate: its benefit can be
  destroyed by premature simplification using the @{thm concat_partition_by} simplification rule.›

lemma fill_holes_induct2[consumes 2, case_names MHole MVar MFun]:
  fixes P :: "('f,'v) mctxt ⇒ 'a list ⇒ 'b list ⇒ bool"
  assumes len1: "num_holes C = length xs" and len2: "num_holes C = length ys"
  and Hole: "⋀x y. P MHole [x] [y]"
  and Var: "⋀v. P (MVar v) [] []"
  and Fun: "⋀f Cs xs ys.  sum_list (map num_holes Cs) = length xs ⟹
    sum_list (map num_holes Cs) = length ys ⟹
    (⋀i. i < length Cs ⟹ P (Cs ! i) (partition_holes xs Cs ! i) (partition_holes ys Cs ! i)) ⟹
    P (MFun f Cs) (concat (partition_holes xs Cs)) (concat (partition_holes ys Cs))"
  shows "P C xs ys"
proof (insert len1 len2, induct C arbitrary: xs ys)
  case MHole then show ?case using Hole by (cases xs; cases ys) auto
next
  case (MVar v) then show ?case using Var by auto
next
  case (MFun f Cs) then show ?case using Fun[of Cs xs ys f] by (auto simp: length_partition_by_nth)
qed

lemma fill_holes_induct[consumes 1, case_names MHole MVar MFun]:
  fixes P :: "('f,'v) mctxt ⇒ 'a list ⇒ bool"
  assumes len: "num_holes C = length xs"
  and Hole: "⋀x. P MHole [x]"
  and Var: "⋀v. P (MVar v) []"
  and Fun: "⋀f Cs xs. sum_list (map num_holes Cs) = length xs ⟹
    (⋀i. i < length Cs ⟹ P (Cs ! i) (partition_holes xs Cs ! i)) ⟹
    P (MFun f Cs) (concat (partition_holes xs Cs))"
  shows "P C xs"
  using fill_holes_induct2[of C xs xs "λ C xs _. P C xs"] assms by simp

lemma length_partition_holes_nth [simp]:
  assumes "sum_list (map num_holes cs) = length ts"
    and "i < length cs"
  shows "length (partition_holes ts cs ! i) = num_holes (cs ! i)"
  using assms by (simp add: length_partition_by_nth)

(*some compatibility lemmas (which should be dropped eventually)*)
lemmas
  map_partition_holes_nth [simp] =
    map_partition_by_nth [of _ "map num_holes Cs" for Cs, unfolded length_map] and
  length_partition_holes [simp] =
    length_partition_by [of _ "map num_holes Cs" for Cs, unfolded length_map]

lemma fill_holes_term_of_mctxt:
  "num_holes C = 0 ⟹ fill_holes C [] = term_of_mctxt C"
  by (induct C) (auto simp add: map_eq_nth_conv)

lemma fill_holes_MHole:
  "length ts = Suc 0 ⟹ ts ! 0 = u ⟹ fill_holes MHole ts = u"
  by (cases ts) simp_all

lemma fill_holes_arbitrary:
  assumes lCs: "length Cs = length ts"
    and lss: "length ss = length ts"
    and rec: "⋀ i. i < length ts ⟹ num_holes (Cs ! i) = length (ss ! i) ∧ f (Cs ! i) (ss ! i) = ts ! i"
  shows "map (λi. f (Cs ! i) (partition_holes (concat ss) Cs ! i)) [0 ..< length Cs] = ts"
proof -
  have "sum_list (map num_holes Cs) = length (concat ss)" using assms
    by (auto simp: length_concat map_nth_eq_conv intro: arg_cong[of _ _ "sum_list"])
  moreover have "partition_holes (concat ss) Cs = ss"
    using assms by (auto intro: partition_by_concat_id)
  ultimately show ?thesis using assms by (auto intro: nth_equalityI)
qed

lemma fill_holes_MFun:
  assumes lCs: "length Cs = length ts"
    and lss: "length ss = length ts"
    and rec: "⋀ i. i < length ts ⟹ num_holes (Cs ! i) = length (ss ! i) ∧ fill_holes (Cs ! i) (ss ! i) = ts ! i"
  shows "fill_holes (MFun f Cs) (concat ss) = Fun f ts" 
  unfolding fill_holes.simps term.simps
    by (rule conjI[OF refl], rule fill_holes_arbitrary[OF lCs lss rec])

lemma eqfE:
  assumes "t =f (D, ss)" shows "t = fill_holes D ss" "num_holes D = length ss"
  using assms[unfolded eq_fill.simps] by auto

lemma eqf_MFunE:
  assumes "s =f (MFun f Cs,ss)"  
  obtains ts sss where "s = Fun f ts" "length ts = length Cs" "length sss = length Cs" 
  "⋀ i. i < length Cs ⟹ ts ! i =f (Cs ! i, sss ! i)"
  "ss = concat sss"
proof -
  from eqfE[OF assms] have fh: "s = fill_holes (MFun f Cs) ss" 
    and nh: "sum_list (map num_holes Cs) = length ss" by auto
  from fh obtain ts where s: "s = Fun f ts" by (cases s, auto)
  from fh[unfolded s] 
  have ts: "ts = map (λi. fill_holes (Cs ! i) (partition_holes ss Cs ! i)) [0..<length Cs]" 
    (is "_ = map (?f Cs ss) _")
    by auto
  let ?sss = "partition_holes ss Cs"
  from nh 
  have *: "length ?sss = length Cs" "⋀i. i < length Cs ⟹ ts ! i =f (Cs ! i, ?sss ! i)" "ss = concat ?sss"
    by (auto simp: ts)
  have len: "length ts = length Cs" unfolding ts by auto
  assume ass: "⋀ts sss. s = Fun f ts ⟹
              length ts = length Cs ⟹
              length sss = length Cs ⟹ (⋀i. i < length Cs ⟹ ts ! i =f (Cs ! i, sss ! i)) ⟹ ss = concat sss ⟹ thesis"
  show thesis
    by (rule ass[OF s len *])
qed

lemma eqf_MFunI:
  assumes "length sss = length Cs"
    and "length ts = length Cs"
    and"⋀ i. i < length Cs ⟹ ts ! i =f (Cs ! i, sss ! i)"
  shows "Fun f ts =f (MFun f Cs, concat sss)"
proof 
  have "num_holes (MFun f Cs) = sum_list (map num_holes Cs)" by simp
  also have "map num_holes Cs = map length sss"
    by (rule nth_equalityI, insert assms eqfE[OF assms(3)], auto)
  also have "sum_list (…) = length (concat sss)" unfolding length_concat ..
  finally show "num_holes (MFun f Cs) = length (concat sss)" .
  show "Fun f ts = fill_holes (MFun f Cs) (concat sss)"
    by (rule fill_holes_MFun[symmetric], insert assms(1,2) eqfE[OF assms(3)], auto)
qed

lemma split_vars_ground_vars:
  assumes "ground_mctxt C" and "num_holes C = length xs" 
  shows "split_vars (fill_holes C (map Var xs)) = (C, xs)" using assms
proof (induct C arbitrary: xs)
  case (MHole xs)
  then show ?case by (cases xs, auto)
next
  case (MFun f Cs xs)
  have "fill_holes (MFun f Cs) (map Var xs) =f (MFun f Cs, map Var xs)"
    by (rule eqfI, insert MFun(3), auto)
  from eqf_MFunE[OF this] 
  obtain ts xss where fh: "fill_holes (MFun f Cs) (map Var xs) = Fun f ts"
    and lent: "length ts = length Cs"
    and lenx: "length xss = length Cs"
    and args: "⋀i. i < length Cs ⟹ ts ! i =f (Cs ! i, xss ! i)"
    and id: "map Var xs = concat xss" by auto
  from arg_cong[OF id, of "map the_Var"] have id2: "xs = concat (map (map the_Var) xss)" 
    by (metis map_concat length_map map_nth_eq_conv term.sel(1))    
  {
    fix i
    assume i: "i < length Cs"
    then have mem: "Cs ! i ∈ set Cs" by auto
    with MFun(2) have ground: "ground_mctxt (Cs ! i)" by auto
    have "map Var (map the_Var (xss ! i)) = map id (xss ! i)" unfolding map_map o_def map_eq_conv
    proof
      fix x
      assume "x ∈ set (xss ! i)"
      with lenx i have "x ∈ set (concat xss)" by auto
      from this[unfolded id[symmetric]] show "Var (the_Var x) = id x" by auto
    qed
    then have idxss: "map Var (map the_Var (xss ! i)) = xss ! i" by auto
    note rec = eqfE[OF args[OF i]]
    note IH = MFun(1)[OF mem ground, of "map the_Var (xss ! i)", unfolded rec(2) idxss rec(1)[symmetric]]
    from IH have "split_vars (ts ! i) = (Cs ! i, map the_Var (xss ! i))" by auto
    note this idxss
  }
  note IH = this
  have "?case = (map fst (map split_vars ts) = Cs ∧ concat (map snd (map split_vars ts)) = concat (map (map the_Var) xss))"
    unfolding fh unfolding id2 by auto
  also have "…"
  proof (rule conjI[OF nth_equalityI arg_cong[of _ _ concat, OF nth_equalityI, rule_format]], unfold length_map lent lenx)
    fix i
    assume i: "i < length Cs" 
    with arg_cong[OF IH(2)[OF this], of "map the_Var"]
      IH[OF this] show "map snd (map split_vars ts) ! i = map (map the_Var) xss ! i" using lent lenx by auto
  qed (insert IH lent, auto)
  finally show ?case .
qed auto


lemma split_vars_vars_term_list: "snd (split_vars t) = vars_term_list t"
proof (induct t)
  case (Fun f ts)
  then show ?case by (auto simp: vars_term_list.simps o_def, induct ts, auto)
qed (auto simp: vars_term_list.simps)


lemma split_vars_num_holes: "num_holes (fst (split_vars t)) = length (snd (split_vars t))"
proof (induct t)
  case (Fun f ts)
  then show ?case by (induct ts, auto)
qed simp

lemma ground_eq_fill: "t =f (C,ss) ⟹ ground t = (ground_mctxt C ∧ (∀ s ∈ set ss. ground s))" 
proof (induct C arbitrary: t ss)
  case (MVar x)
  from eqfE[OF this] show ?case by simp
next
  case (MHole t ss)
  from eqfE[OF this] show ?case by (cases ss, auto)
next
  case (MFun f Cs s ss)
  from eqf_MFunE[OF MFun(2)] obtain ts sss where s: "s = Fun f ts" and len: "length ts = length Cs" "length sss = length Cs" 
    and IH: "⋀ i. i < length Cs ⟹ ts ! i =f (Cs ! i, sss ! i)" and ss: "ss = concat sss" by metis
  {
    fix i
    assume i: "i < length Cs"
    then have "Cs ! i ∈ set Cs" by simp
    from MFun(1)[OF this IH[OF i]]
    have "ground (ts ! i) = (ground_mctxt (Cs ! i) ∧ (∀a∈set (sss ! i). ground a))" .
  } note IH = this
  note conv = set_conv_nth
  have "?case = ((∀x∈set ts. ground x) = ((∀x∈set Cs. ground_mctxt x) ∧ (∀a∈set sss. ∀x∈set a. ground x)))"
    unfolding s ss by simp
  also have "..." unfolding conv[of ts] conv[of Cs] conv[of sss] len using IH by auto
  finally show ?case by simp
qed

lemma ground_fill_holes:
  assumes nh: "num_holes C = length ss"
  shows "ground (fill_holes C ss) = (ground_mctxt C ∧ (∀ s ∈ set ss. ground s))"
  by (rule ground_eq_fill[OF eqfI[OF refl nh]])

lemma split_vars_ground' [simp]:
  "ground_mctxt (fst (split_vars t))"
  by (induct t) auto

lemma split_vars_funas_mctxt [simp]:
  "funas_mctxt (fst (split_vars t)) = funas_term t"
  by (induct t) auto


lemma less_eq_mctxt_prime: "C ≤ D ⟷ less_eq_mctxt' C D"
proof
  assume "less_eq_mctxt' C D" then show "C ≤ D"
    by (induct C D rule: less_eq_mctxt'.induct) (auto simp: less_eq_mctxt_def intro: nth_equalityI)
next
  assume "C ≤ D" then show "less_eq_mctxt' C D" unfolding less_eq_mctxt_def
  by (induct C D rule: inf_mctxt.induct)
     (auto split: if_splits simp: set_zip intro!: less_eq_mctxt'.intros nth_equalityI elim!: nth_equalityE, metis)
qed

lemmas less_eq_mctxt_induct = less_eq_mctxt'.induct[folded less_eq_mctxt_prime, consumes 1]
lemmas less_eq_mctxt_intros = less_eq_mctxt'.intros[folded less_eq_mctxt_prime]

lemma less_eq_mctxt_MHoleE2:
  assumes "C ≤ MHole"
  obtains (MHole) "C = MHole"
  using assms unfolding less_eq_mctxt_prime by (cases C, auto)

lemma less_eq_mctxt_MVarE2:
  assumes "C ≤ MVar v"
  obtains (MHole) "C = MHole" | (MVar) "C = MVar v"
  using assms unfolding less_eq_mctxt_prime by (cases C) auto

lemma less_eq_mctxt_MFunE2:
  assumes "C ≤ MFun f ds"
  obtains (MHole) "C = MHole"
    | (MFun) cs where "C = MFun f cs" "length cs = length ds" "⋀i. i < length cs ⟹ cs ! i ≤ ds ! i"
  using assms unfolding less_eq_mctxt_prime by (cases C) auto

lemmas less_eq_mctxtE2 = less_eq_mctxt_MHoleE2 less_eq_mctxt_MVarE2 less_eq_mctxt_MFunE2


lemma less_eq_mctxt_MVarE1:
  assumes "MVar v ≤ D"
  obtains (MVar) "D = MVar v"
  using assms by (cases D) (auto elim: less_eq_mctxtE2)

lemma MHole_Bot [simp]: "MHole ≤ D"
  by (simp add: less_eq_mctxt_intros(1))

lemma less_eq_mctxt_MFunE1:
  assumes "MFun f cs ≤ D"
  obtains (MFun) ds where "D = MFun f ds" "length cs = length ds" "⋀i. i < length cs ⟹ cs ! i ≤ ds ! i"
  using assms by (cases D) (auto elim: less_eq_mctxtE2)


lemma length_unfill_holes [simp]:
  assumes "C ≤ mctxt_of_term t"
  shows "length (unfill_holes C t) = num_holes C"
  using assms
proof (induct C t rule: unfill_holes.induct)
  case (3 f Cs g ts) with 3(1)[OF _ nth_mem] 3(2) show ?case
    by (auto simp: less_eq_mctxt_def length_concat
      intro!: cong[of sum_list, OF refl] nth_equalityI elim!: nth_equalityE)
qed (auto simp: less_eq_mctxt_def)

lemma map_vars_mctxt_id [simp]:
  "map_vars_mctxt (λ x. x) C = C"
  by (induct C, auto intro: nth_equalityI)


lemma split_vars_eqf_subst_map_vars_term:
  "t ⋅ σ =f (map_vars_mctxt vw (fst (split_vars t)), map σ (snd (split_vars t)))"
proof (induct t)
  case (Fun f ts)
  have "?case = (Fun f (map (λt. t ⋅ σ) ts)
    =f (MFun f (map (map_vars_mctxt vw ∘ (fst ∘ split_vars)) ts), concat (map (map σ ∘ (snd ∘ split_vars)) ts)))"
    by (simp add: map_concat)
  also have "..." 
  proof (rule eqf_MFunI, simp, simp, unfold length_map)
    fix i
    assume i: "i < length ts"
    then have mem: "ts ! i ∈ set ts" by auto
    show "map (λt. t ⋅ σ) ts ! i =f (map (map_vars_mctxt vw ∘ (fst ∘ split_vars)) ts ! i, map (map σ ∘ (snd ∘ split_vars)) ts ! i)"
      using Fun[OF mem] i by auto
  qed
  finally show ?case by simp
qed auto

lemma split_vars_eqf_subst: "t ⋅ σ =f (fst (split_vars t), (map σ (snd (split_vars t))))"
  using split_vars_eqf_subst_map_vars_term[of t σ "λ x. x"] by simp

lemma split_vars_fill_holes:
  assumes "C = fst (split_vars s)" and "ss = map Var (snd (split_vars s))"
  shows "fill_holes C ss = s" using assms
  by (metis eqfE(1) split_vars_eqf_subst subst_apply_term_empty)


lemma fill_unfill_holes:
  assumes "C ≤ mctxt_of_term t"
  shows "fill_holes C (unfill_holes C t) = t"
  using assms
proof (induct C t rule: unfill_holes.induct)
  case (3 f Cs g ts) with 3(1)[OF _ nth_mem] 3(2) show ?case
    by (auto simp: less_eq_mctxt_def intro!: fill_holes_arbitrary elim!: nth_equalityE)
qed (auto simp: less_eq_mctxt_def split: if_splits)


lemma hole_poss_list_length:
  "length (hole_poss_list D) = num_holes D"
  by (induct D) (auto simp: length_concat intro!: nth_sum_listI)

lemma unfill_holles_hole_poss_list_length:
  assumes "C ≤ mctxt_of_term t"
  shows "length (unfill_holes C t) = length (hole_poss_list C)" using assms
proof (induct C arbitrary: t)
  case (MVar x)
  then have [simp]: "t = Var x" by (cases t) (auto dest: less_eq_mctxt_MVarE1)
  show ?case by simp
next
  case (MFun f ts) then show ?case
    by (cases t) (auto simp: length_concat comp_def
      elim!: less_eq_mctxt_MFunE1 less_eq_mctxt_MVarE1 intro!: nth_sum_listI)
qed auto

lemma unfill_holes_to_subst_at_hole_poss:
  assumes "C ≤ mctxt_of_term t"
  shows "unfill_holes C t = map ((|_) t) (hole_poss_list C)" using assms
proof (induct C arbitrary: t)
  case (MVar x)
  then show ?case by (cases t) (auto elim: less_eq_mctxt_MVarE1)
next
  case (MFun f ts)
  from MFun(2) obtain ss where [simp]: "t = Fun f ss" and l: "length ts = length ss"
    by (cases t) (auto elim: less_eq_mctxt_MFunE1)
  let ?ts = "map (λi. unfill_holes (ts ! i) (ss ! i)) [0..<length ts]"
  let ?ss = "map (λ x. map ((|_) (Fun f ss)) (case x of (x, y) ⇒ map ((#) x) (hole_poss_list y))) (zip [0..<length ts] ts)"
  have eq_l [simp]: "length (concat ?ts) = length (concat ?ss)" using MFun
    by (auto simp: length_concat comp_def elim!: less_eq_mctxt_MFunE1 split!: prod.splits intro!: nth_sum_listI)
  {fix i assume ass: "i < length (concat ?ts)"
    then have lss: "i < length (concat ?ss)" by auto
    obtain m n where [simp]: "concat_index_split (0, i) ?ts = (m, n)" by fastforce
    then have [simp]: "concat_index_split (0, i) ?ss = (m, n)" using concat_index_split_unique[OF ass, of ?ss 0] MFun(2)
      by (auto simp: unfill_holles_hole_poss_list_length[of "ts ! i" "ss ! i" for i]
       simp del: length_unfill_holes elim!: less_eq_mctxt_MFunE1)
    from concat_index_split_less_length_concat(2-)[OF ass ] concat_index_split_less_length_concat(2-)[OF lss]
    have "concat ?ts ! i = concat ?ss! i" using MFun(1)[OF nth_mem, of m "ss ! m"] MFun(2)
      by (auto elim!: less_eq_mctxt_MFunE1)} note nth = this
  show ?case using MFun
    by (auto simp: comp_def map_concat length_concat
        elim!: less_eq_mctxt_MFunE1 split!: prod.splits
        intro!: nth_equalityI nth_sum_listI nth)
qed auto

lemma hole_poss_split_varposs_list_length [simp]:
  "length (hole_poss_list (fst (split_vars t))) = length (varposs_list t)"
  by (induct t)(auto simp: length_concat comp_def intro!: nth_sum_listI)

lemma hole_poss_split_vars_varposs_list:
  "hole_poss_list (fst (split_vars t)) = varposs_list t"
proof (induct t)
  case (Fun f ts)
  let ?ts = "poss_args hole_poss_list (map (fst ∘ split_vars) ts)"
  let ?ss = "poss_args varposs_list ts"
  have len: "length (concat ?ts) = length (concat ?ss)" "length ?ts = length ?ss"
    "∀ i < length ?ts. length (?ts ! i) = length (?ss ! i)" by (auto intro: eq_length_concat_nth)
  {fix i assume ass: "i < length (concat ?ts)"
    then have lss: "i < length (concat ?ss)" using len by auto
    obtain m n where int: "concat_index_split (0, i) ?ts = (m, n)" by fastforce
    then have [simp]: "concat_index_split (0, i) ?ss = (m, n)" using concat_index_split_unique[OF ass len(2-)] by auto
    from concat_index_split_less_length_concat(2-)[OF ass int] concat_index_split_less_length_concat(2-)[OF lss]
    have "concat ?ts ! i = concat ?ss! i" using Fun[OF nth_mem, of m] by auto}
  then show ?case using len by (auto intro: nth_equalityI)
qed auto



lemma funas_term_fill_holes_iff: "num_holes C = length ts ⟹
   g ∈ funas_term (fill_holes C ts) ⟷ g ∈ funas_mctxt C ∨ (∃t ∈ set ts. g ∈ funas_term t)"
proof (induct C ts rule: fill_holes_induct)
  case (MFun f Cs ts)
  have "(∃i < length Cs. g ∈ funas_term (fill_holes (Cs ! i) (partition_holes (concat (partition_holes ts Cs)) Cs ! i)))
    ⟷ (∃C ∈ set Cs. g ∈ funas_mctxt C) ∨ (∃us ∈ set (partition_holes ts Cs). ∃t ∈ set us. g ∈ funas_term t)"
    using MFun by (auto simp: ex_set_conv_ex_nth) blast
  then show ?case by auto
qed auto

lemma vars_term_fill_holes [simp]:
  "num_holes C = length ts ⟹ ground_mctxt C ⟹
    vars_term (fill_holes C ts) = ⋃(vars_term ` set ts)"
proof (induct C arbitrary: ts)
  case MHole
  then show ?case by (cases ts) simp_all
next
  case (MFun f Cs)
  then have *: "length (partition_holes ts Cs) = length Cs" by simp
  let ?f = "λx. ⋃y ∈ set x. vars_term y"
  show ?case
    using MFun
    unfolding partition_holes_fill_holes_conv
    by (simp add: UN_upt_len_conv [OF *, of ?f] UN_set_partition_by)
qed simp



lemma funas_mctxt_fill_holes [simp]:
  assumes "num_holes C = length ts"
  shows "funas_term (fill_holes C ts) = funas_mctxt C ∪ ⋃(set (map funas_term ts))"
  using funas_term_fill_holes_iff[OF assms] by auto

lemma funas_mctxt_fill_holes_mctxt [simp]:
  assumes "num_holes C = length Ds"
  shows "funas_mctxt (fill_holes_mctxt C Ds) = funas_mctxt C ∪ ⋃(set (map funas_mctxt Ds))"
  (is "?f C Ds = ?g C Ds")
using assms
proof (induct C arbitrary: Ds)
  case MHole
  then show ?case by (cases Ds) simp_all
next
  case (MFun f Cs)
  then have num_holes: "sum_list (map num_holes Cs) = length Ds" by simp
  let ?ys = "partition_holes Ds Cs"
  have "⋀i. i < length Cs ⟹ ?f (Cs ! i) (?ys ! i) = ?g (Cs ! i) (?ys ! i)"
    using MFun by (metis nth_mem num_holes.simps(3) length_partition_holes_nth)
  then have "(⋃i ∈ {0 ..< length Cs}. ?f (Cs ! i) (?ys ! i)) =
    (⋃i ∈ {0 ..< length Cs}. ?g (Cs ! i) (?ys ! i))" by simp
  then show ?case
    using num_holes
    unfolding partition_holes_fill_holes_mctxt_conv
    by (simp add: UN_Un_distrib UN_upt_len_conv [of _ _ "λx. ⋃(set x)"] UN_set_partition_by_map)
qed simp

end
dy>

Theory Ground_MCtxt

theory Ground_MCtxt
  imports
   Multihole_Context
   Regular_Tree_Relations.Ground_Terms
   Regular_Tree_Relations.Ground_Ctxt
begin

subsection ‹Ground multihole context›

datatype (gfuns_mctxt: 'f) gmctxt = GMHole | GMFun 'f "'f gmctxt list"

subsubsection ‹Basic function on ground mutlihole contexts›

primrec gmctxt_of_gterm :: "'f gterm ⇒ 'f gmctxt" where
  "gmctxt_of_gterm (GFun f ts) = GMFun f (map gmctxt_of_gterm ts)"

fun num_gholes :: "'f gmctxt ⇒ nat" where
  "num_gholes GMHole = Suc 0"
| "num_gholes (GMFun _ ctxts) = sum_list (map num_gholes ctxts)"

primrec gterm_of_gmctxt :: "'f gmctxt ⇒ 'f gterm" where
  "gterm_of_gmctxt (GMFun f Cs) = GFun f (map gterm_of_gmctxt Cs)"

primrec term_of_gmctxt :: "'f gmctxt ⇒ ('f, 'v) term" where
  "term_of_gmctxt (GMFun f Cs) = Fun f (map term_of_gmctxt Cs)"

primrec gmctxt_of_gctxt :: "'f gctxt ⇒ 'f gmctxt" where
  "gmctxt_of_gctxt □G = GMHole"
| "gmctxt_of_gctxt (GMore f ss C ts) =
    GMFun f (map gmctxt_of_gterm ss @ gmctxt_of_gctxt C # map gmctxt_of_gterm ts)"

fun gctxt_of_gmctxt :: "'f gmctxt ⇒ 'f gctxt" where
  "gctxt_of_gmctxt GMHole = □G"
| "gctxt_of_gmctxt (GMFun f Cs) = (let n = length (takeWhile (λ C. num_gholes C = 0) Cs) in
     (if n < length Cs then
        GMore f (map gterm_of_gmctxt (take n Cs)) (gctxt_of_gmctxt (Cs ! n)) (map gterm_of_gmctxt (drop (Suc n) Cs))
      else undefined))"

primrec gmctxt_of_mctxt :: "('f, 'v) mctxt ⇒ 'f gmctxt" where
   "gmctxt_of_mctxt MHole = GMHole"
|  "gmctxt_of_mctxt (MFun f Cs) = GMFun f (map gmctxt_of_mctxt Cs)"

primrec mctxt_of_gmctxt :: "'f gmctxt ⇒ ('f, 'v) mctxt" where
   "mctxt_of_gmctxt GMHole = MHole"
|  "mctxt_of_gmctxt (GMFun f Cs) = MFun f (map mctxt_of_gmctxt Cs)"

fun funas_gmctxt where
  "funas_gmctxt (GMFun f Cs) = {(f, length Cs)} ∪ ⋃(funas_gmctxt ` set Cs)" |
  "funas_gmctxt _ = {}"

abbreviation "partition_gholes xs Cs ≡ partition_by xs (map num_gholes Cs)"

fun fill_gholes :: "'f gmctxt ⇒ 'f gterm list ⇒ 'f gterm" where
  "fill_gholes GMHole [t] = t"
| "fill_gholes (GMFun f cs) ts = GFun f (map (λ i. fill_gholes (cs ! i)
    (partition_gholes ts cs ! i)) [0 ..< length cs])"

fun fill_gholes_gmctxt :: "'f gmctxt ⇒ 'f gmctxt list ⇒ 'f gmctxt" where
  "fill_gholes_gmctxt GMHole [] = GMHole" |
  "fill_gholes_gmctxt GMHole [t] = t" |
  "fill_gholes_gmctxt (GMFun f cs) ts = (GMFun f (map (λ i. fill_gholes_gmctxt (cs ! i) 
    (partition_gholes ts cs ! i)) [0 ..< length cs]))"

subsubsection ‹An inverse of @{term fill_gholes}›
fun unfill_gholes :: "'f gmctxt ⇒ 'f gterm ⇒ 'f gterm list" where
  "unfill_gholes GMHole t = [t]"
| "unfill_gholes (GMFun g Cs) (GFun f ts) = (if f = g ∧ length ts = length Cs then
    concat (map (λi. unfill_gholes (Cs ! i) (ts ! i)) [0..<length ts]) else undefined)"

fun sup_gmctxt_args :: "'f gmctxt ⇒ 'f gmctxt ⇒ 'f gmctxt list" where
  "sup_gmctxt_args GMHole D = [D]" |
  "sup_gmctxt_args C GMHole = replicate (num_gholes C) GMHole" |
  "sup_gmctxt_args (GMFun f Cs) (GMFun g Ds) =
    (if f = g ∧ length Cs = length Ds then concat (map (case_prod sup_gmctxt_args) (zip Cs Ds))
    else undefined)"

fun ghole_poss :: "'f gmctxt ⇒ pos set" where
  "ghole_poss GMHole = {[]}" |
  "ghole_poss (GMFun f cs) = ⋃(set (map (λ i. (λ p. i # p) ` ghole_poss (cs ! i)) [0 ..< length cs]))"

abbreviation "poss_rec f ts ≡ map2 (λ i t. map ((#) i) (f t)) ([0 ..< length ts]) ts"
fun ghole_poss_list :: "'f gmctxt ⇒ pos list" where
  "ghole_poss_list GMHole = [[]]"
| "ghole_poss_list (GMFun f cs) = concat (poss_rec ghole_poss_list cs)"


fun poss_gmctxt :: "'f gmctxt ⇒ pos set" where
  "poss_gmctxt GMHole = {}" |
  "poss_gmctxt (GMFun f cs) = {[]} ∪ ⋃(set (map (λ i. (λ p. i # p) ` poss_gmctxt (cs ! i)) [0 ..< length cs]))"

lemma poss_simps [simp]:
  "ghole_poss (GMFun f Cs) = {i # p | i p. i < length Cs ∧ p ∈ ghole_poss (Cs ! i)}"
  "poss_gmctxt (GMFun f Cs) = {[]} ∪ {i # p | i p. i < length Cs ∧ p ∈ poss_gmctxt (Cs ! i)}"
  by auto

fun ghole_num_bef_pos where
  "ghole_num_bef_pos [] _ = 0" |
  "ghole_num_bef_pos (i # q) (GMFun f Cs) = sum_list (map num_gholes (take i Cs)) + ghole_num_bef_pos q (Cs ! i)"

fun ghole_num_at_pos where
  "ghole_num_at_pos [] C = num_gholes C" |
  "ghole_num_at_pos (i # q) (GMFun f Cs) = ghole_num_at_pos q (Cs ! i)"

fun subgm_at :: "'f gmctxt ⇒ pos ⇒ 'f gmctxt" where
  "subgm_at C [] = C"
| "subgm_at (GMFun f Cs) (i # p) = subgm_at (Cs ! i) p"

definition gmctxt_subtgm_at_fill_args where
  "gmctxt_subtgm_at_fill_args p C ts = take (ghole_num_at_pos p C) (drop (ghole_num_bef_pos p C) ts)"

(*
declare hole_poss.simps(2)[simp del]
declare poss_mctxt.simps(2)[simp del]
*)

instantiation gmctxt :: (type) inf
begin

fun inf_gmctxt :: "'a gmctxt ⇒ 'a gmctxt ⇒ 'a gmctxt" where
  "GMHole ⊓ D = GMHole" |
  "C ⊓ GMHole = GMHole" |
  "GMFun f Cs ⊓ GMFun g Ds =
    (if f = g ∧ length Cs = length Ds then GMFun f (map (case_prod (⊓)) (zip Cs Ds))
    else GMHole)"

instance ..
end

instantiation gmctxt :: (type) sup
begin

fun sup_gmctxt :: "'a gmctxt ⇒ 'a gmctxt ⇒ 'a gmctxt" where
  "GMHole ⊔ D = D" |
  "C ⊔ GMHole = C" |
  "GMFun f Cs ⊔ GMFun g Ds =
    (if f = g ∧ length Cs = length Ds then GMFun f (map (case_prod (⊔)) (zip Cs Ds))
    else undefined)"

instance ..
end

subsubsection ‹Orderings and compatibility of ground multihole contexts›

inductive less_eq_gmctxt :: "'f gmctxt ⇒ 'f gmctxt ⇒ bool" where
 base [simp]: "less_eq_gmctxt GMHole u"
| ind[intro]: "length cs = length ds ⟹ (⋀i. i < length cs ⟹ less_eq_gmctxt (cs ! i) (ds ! i)) ⟹
     less_eq_gmctxt (GMFun f cs) (GMFun f ds)"

inductive_set comp_gmctxt :: "('f gmctxt × 'f gmctxt) set" where
  GMHole1 [simp]: "(GMHole, D) ∈ comp_gmctxt" |
  GMHole2 [simp]: "(C, GMHole) ∈ comp_gmctxt" |
  GMFun [intro]: "f = g ⟹ length Cs = length Ds ⟹ ∀i < length Ds. (Cs ! i, Ds ! i) ∈ comp_gmctxt ⟹
    (GMFun f Cs, GMFun g Ds) ∈ comp_gmctxt"

definition gmctxt_closing where
  "gmctxt_closing C D ⟷ less_eq_gmctxt C D ∧ ghole_poss D ⊆ ghole_poss C"


inductive eq_gfill ("(_/ =Gf _)" [51, 51] 50) where
  eqfI [intro]: "t = fill_gholes D ss ⟹ num_gholes D = length ss ⟹ t =Gf (D, ss)"

subsubsection ‹Conversions from and to ground multihole contexts›

lemma num_gholes_o_gmctxt_of_gterm [simp]:
  "num_gholes ∘ gmctxt_of_gterm = (λx. 0)"
  by (rule ext, induct_tac x) simp_all

lemma mctxt_of_term_term_of_mctxt_id [simp]:
  "num_gholes C = 0 ⟹ gmctxt_of_gterm (gterm_of_gmctxt C) = C"
  by (induct C) (simp_all add: map_idI)

lemma num_holes_mctxt_of_term [simp]:
  "num_gholes (gmctxt_of_gterm t) = 0"
  by (induct t) simp_all

lemma num_gholes_gmctxt_of_mctxt [simp]:
  "ground_mctxt C ⟹ num_gholes (gmctxt_of_mctxt C) = num_holes C"
  by (induct C) (auto intro: nth_sum_listI)

lemma num_holes_mctxt_of_gmctxt [simp]:
  "num_holes (mctxt_of_gmctxt C) = num_gholes C"
  by (induct C) (auto intro: nth_sum_listI)

lemma num_holes_mctxt_of_gmctxt_fun_comp [simp]:
  "num_holes ∘ mctxt_of_gmctxt = num_gholes"
  by (auto simp: comp_def)

lemma gmctxt_of_gctxt_num_gholes [simp]:
  "num_gholes (gmctxt_of_gctxt C) = Suc 0"
  by (induct C) auto

lemma ground_mctxt_list_num_gholes_gmctxt_of_mctxt_conv [simp]:
  "∀x∈set Cs. ground_mctxt x ⟹ map (num_gholes ∘ gmctxt_of_mctxt) Cs = map num_holes Cs"
  by auto


lemma num_gholes_map_gmctxt [simp]:
  "num_gholes (map_gmctxt f C) = num_gholes C"
  by (induct C)  (auto simp: comp_def, metis (no_types, lifting) map_eq_conv)

lemma map_num_gholes_map_gmctxt [simp]:
  "map (num_gholes ∘ map_gmctxt f) Cs = map num_gholes Cs"
  by (induct Cs) auto

lemma gterm_of_gmctxt_gmctxt_of_gterm_id [simp]:
  "gterm_of_gmctxt (gmctxt_of_gterm t) = t"
  by (induct t) (simp_all add: map_idI)

lemma no_gholes_gmctxt_of_gterm_gterm_of_gmctxt_id [simp]:
  "num_gholes C = 0 ⟹ gmctxt_of_gterm (gterm_of_gmctxt C) = C"
  by (induct C) (auto simp: comp_def intro: nth_equalityI)

lemma no_gholes_term_of_gterm_gterm_of_gmctxt [simp]:
  "num_gholes C = 0 ⟹ term_of_gterm (gterm_of_gmctxt C) = term_of_gmctxt C"
  by (induct C) (auto simp: comp_def intro: nth_equalityI)

lemma no_gholes_term_of_mctxt_mctxt_of_gmctxt [simp]:
  "num_gholes C = 0 ⟹ term_of_mctxt (mctxt_of_gmctxt C) = term_of_gmctxt C"
  by (induct C) (auto simp: comp_def intro: nth_equalityI)

lemma nthWhile_gmctxt_of_gctxt [simp]:
  "length (takeWhile (λC. num_gholes C = 0) (map gmctxt_of_gterm ss @ gmctxt_of_gctxt C # ts)) = length ss"
  by (induct ss) auto

lemma sum_list_nthWhile_length [simp]:
  "sum_list (map num_gholes Cs) = Suc 0 ⟹ length (takeWhile (λC. num_gholes C = 0) Cs) < length Cs"
  by (induct Cs) auto

lemma gctxt_of_gmctxt_gmctxt_of_gctxt [simp]:
  "gctxt_of_gmctxt (gmctxt_of_gctxt C) = C"
  by (induct C) (auto simp: Let_def comp_def nth_append)

lemma gmctxt_of_gctxt_GMHole_Hole:
  "gmctxt_of_gctxt C = GMHole ⟹ C = □G"
  by (metis gctxt_of_gmctxt.simps(1) gctxt_of_gmctxt_gmctxt_of_gctxt)

lemma gmctxt_of_gctxt_gctxt_of_gmctxt:
  "num_gholes C = Suc 0 ⟹ gmctxt_of_gctxt (gctxt_of_gmctxt C) = C"
proof (induct C)
  case (GMFun f Cs)
  then obtain i where nth: "i < length Cs" "i = length (takeWhile (λC. num_gholes C = 0) Cs)"
    using sum_list_nthWhile_length by auto
  then have "0 < num_gholes (Cs ! i)" unfolding nth(2) using nth_length_takeWhile
    by auto
  from nth(1) this have num: "num_gholes (Cs ! i) = Suc 0" using GMFun(2)
    by (auto elim!: sum_list_1_E)
  then have [simp]: "map (gmctxt_of_gterm ∘ gterm_of_gmctxt) (drop (Suc i) Cs) = drop (Suc i) Cs" using GMFun(2) nth(1)
    by (auto elim!: sum_list_1_E simp: comp_def intro!: nth_equalityI)
     (metis add.commute add_Suc_right lessI less_diff_conv no_gholes_gmctxt_of_gterm_gterm_of_gmctxt_id not_add_less1)
  have [simp]: "map (gmctxt_of_gterm ∘ gterm_of_gmctxt) (take i Cs) = take i Cs"
    using nth(1) unfolding nth(2) by (induct Cs) auto
  show ?case using id_take_nth_drop[OF nth(1)]
    by (auto simp: Let_def GMFun(1)[OF nth_mem[OF nth(1)] num] simp flip: nth(2))
qed auto

lemma inj_gmctxt_of_gctxt: "inj gmctxt_of_gctxt"
  unfolding inj_def by (metis gctxt_of_gmctxt_gmctxt_of_gctxt)

lemma inj_gctxt_of_gmctxt_on_single_hole:
  "inj_on gctxt_of_gmctxt (Collect (λ C. num_gholes C = Suc 0))"
  by (metis (mono_tags, lifting) gmctxt_of_gctxt_gctxt_of_gmctxt inj_onI mem_Collect_eq)

lemma gctxt_of_gmctxt_hole_dest:
  "num_gholes C = Suc 0 ⟹ gctxt_of_gmctxt C = □G ⟹ C = GMHole"
  by (cases C) (auto simp: Let_def split!: if_splits)

lemma mctxt_of_gmctxt_inv [simp]:
  "gmctxt_of_mctxt (mctxt_of_gmctxt C) = C"
  by (induct C) (simp_all add: map_idI)

lemma ground_mctxt_of_gmctxt [simp]:
  "ground_mctxt (mctxt_of_gmctxt C)"
  by (induct C) auto

lemma ground_mctxt_of_gmctxt' [simp]:
  "mctxt_of_gmctxt C = MFun f D ⟹ ground_mctxt (MFun f D)"
  by (induct C) auto

lemma gmctxt_of_mctxt_inv [simp]:
  "ground_mctxt C ⟹ mctxt_of_gmctxt (gmctxt_of_mctxt C) = C"
  by (induct C) (auto 0 0 intro!: nth_equalityI)

lemma ground_mctxt_of_gmctxtD:
  "ground_mctxt C ⟹ ∃ D. C = mctxt_of_gmctxt D"
  by (metis gmctxt_of_mctxt_inv)

lemma inj_mctxt_of_gmctxt: "inj_on mctxt_of_gmctxt X"
  by (metis inj_on_def mctxt_of_gmctxt_inv)

lemma inj_gmctxt_of_mctxt_ground:
  "inj_on gmctxt_of_mctxt (Collect ground_mctxt)"
  using gmctxt_of_mctxt_inv inj_on_def by force

lemma map_gmctxt_comp [simp]:
  "map_gmctxt f (map_gmctxt g C) = map_gmctxt (f ∘ g) C"
  by (induct C) auto

lemma map_mctxt_of_gmctxt:
  "map_mctxt f (mctxt_of_gmctxt C) = mctxt_of_gmctxt (map_gmctxt f C)"
  by (induct C) auto

lemma map_gmctxt_of_mctxt:
  "ground_mctxt C ⟹ map_gmctxt f (gmctxt_of_mctxt C) = gmctxt_of_mctxt (map_mctxt f C)"
  by (induct C) auto

lemma map_gmctxt_nempty [simp]:
  "C ≠ GMHole ⟹ map_gmctxt f C ≠ GMHole"
  by (cases C) auto


lemma vars_mctxt_of_gmctxt [simp]:
  "vars_mctxt (mctxt_of_gmctxt C) = {}"
  by (induct C) auto

lemma vars_mctxt_of_gmctxt_subseteq [simp]:
  "vars_mctxt (mctxt_of_gmctxt C) ⊆ Q ⟷ True"
  by auto

subsubsection ‹Equivalences and simplification rules›

lemma eqgfE:
  assumes "t =Gf (D, ss)" shows "t = fill_gholes D ss" "num_gholes D = length ss"
  using assms[unfolded eq_gfill.simps] by auto

lemma eqgf_GMHoleE:
  assumes "t =Gf (GMHole, ss)" shows "ss = [t]" using eqgfE[OF assms]
  by (cases ss) auto

lemma eqgf_GMFunE:
  assumes "s =Gf (GMFun f Cs, ss)"  
  obtains ts sss where "s = GFun f ts" "length ts = length Cs" "length sss = length Cs" 
  "⋀ i. i < length Cs ⟹ ts ! i =Gf (Cs ! i, sss ! i)" "ss = concat sss"
proof -
  from eqgfE[OF assms] have fh: "s = fill_gholes (GMFun f Cs) ss" 
    and nh: "sum_list (map num_gholes Cs) = length ss" by auto
  from fh obtain ts where s: "s = GFun f ts" by (cases s, auto)
  from fh[unfolded s] 
  have ts: "ts = map (λi. fill_gholes (Cs ! i) (partition_gholes ss Cs ! i)) [0..<length Cs]" 
    (is "_ = map (?f Cs ss) _")
    by auto
  let ?sss = "partition_gholes ss Cs"
  from nh have *: "length ?sss = length Cs"
    "⋀i. i < length Cs ⟹ ts ! i =Gf (Cs ! i, ?sss ! i)" "ss = concat ?sss"
    by (auto simp: ts length_partition_by_nth)
  have len: "length ts = length Cs" unfolding ts by auto
  assume ass: "⋀ts sss. s = GFun f ts ⟹
              length ts = length Cs ⟹
              length sss = length Cs ⟹ (⋀i. i < length Cs ⟹ ts ! i =Gf (Cs ! i, sss ! i)) ⟹ ss = concat sss ⟹ thesis"
  show thesis by (rule ass[OF s len *])
qed

lemma partition_holes_subseteq [simp]:
  assumes "sum_list (map num_holes Cs) = length xs" "i < length Cs"
    and "x ∈ set (partition_holes xs Cs ! i)"
  shows "x ∈ set xs"
  using assms partition_by_nth_nth_elem length_partition_by_nth
  by (auto simp: in_set_conv_nth) fastforce

lemma partition_gholes_subseteq [simp]:
  assumes "sum_list (map num_gholes Cs) = length xs" "i < length Cs"
    and "x ∈ set (partition_gholes xs Cs ! i)"
  shows "x ∈ set xs"
  using assms partition_by_nth_nth_elem length_partition_by_nth
  by (auto simp: in_set_conv_nth) fastforce

lemma list_elem_to_partition_nth [elim]:
  assumes "sum_list (map num_gholes Cs) = length xs" "x ∈ set xs"
  obtains i where "i < length Cs" "x ∈ set (partition_gholes xs Cs ! i)" using assms
  by (metis concat_partition_by in_set_idx length_map length_partition_by nth_concat_split nth_mem)

lemma partition_holes_fill_gholes_conv':
  "fill_gholes (GMFun f Cs) ts =
    GFun f (map (case_prod fill_gholes) (zip Cs (partition_gholes ts Cs)))"
  unfolding zip_nth_conv [of Cs "partition_gholes ts Cs", simplified]
    and partition_holes_fill_holes_conv by simp

lemma unfill_gholes_conv:
  assumes "length Cs = length ts"
  shows "unfill_gholes (GMFun f Cs) (GFun f ts) =
    concat (map (case_prod unfill_gholes) (zip Cs ts))" using assms
  by (auto simp: zip_nth_conv [of Cs ts, simplified] comp_def)

lemma partition_holes_fill_gholes_gmctxt_conv:
  "fill_gholes_gmctxt (GMFun f Cs) ts =
    GMFun f [fill_gholes_gmctxt (Cs ! i) (partition_gholes ts Cs ! i). i ← [0 ..< length Cs]]"
  by (simp add: partition_by_nth take_map)

lemma partition_holes_fill_gholes_gmctxt_conv':
  "fill_gholes_gmctxt (GMFun f Cs) ts =
    GMFun f (map (case_prod fill_gholes_gmctxt) (zip Cs (partition_gholes ts Cs)))"
  unfolding zip_nth_conv [of Cs "partition_gholes ts Cs", simplified]
    and partition_holes_fill_gholes_gmctxt_conv by simp

lemma fill_gholes_no_holes [simp]:
  "num_gholes C = 0 ⟹ fill_gholes C [] = gterm_of_gmctxt C"
  by (induct C) (auto simp: partition_holes_fill_gholes_conv'
    simp del: fill_gholes.simps intro: nth_equalityI)

lemma fill_gholes_gmctxt_no_holes [simp]:
  "num_gholes C = 0 ⟹ fill_gholes_gmctxt C [] = C"
  by (induct C) (auto intro: nth_equalityI)

lemma eqgf_GMFunI:
  assumes "⋀ i. i < length Cs ⟹ ss ! i =Gf (Cs ! i, ts ! i)"
    and "length Cs = length ss" "length ss = length ts"
  shows "GFun f ss =Gf (GMFun f Cs, concat ts)" using assms
  apply (auto simp del: fill_gholes.simps
    simp: partition_holes_fill_gholes_conv' intro!: eq_gfill.intros nth_equalityI)
  apply (metis eqgfE length_map map_nth_eq_conv partition_by_concat_id)
  by (metis eqgfE(2) length_concat nth_map_conv)

lemma length_partition_gholes_nth:
  assumes "sum_list (map num_gholes cs) = length ts"
    and "i < length cs"
  shows "length (partition_gholes ts cs ! i) = num_gholes (cs ! i)"
  using assms by (simp add: length_partition_by_nth)

lemma fill_gholes_induct2[consumes 2, case_names GMHole GMFun]:
  fixes P :: "'f gmctxt ⇒ 'a list ⇒ 'b list ⇒ bool"
  assumes len1: "num_gholes C = length xs" and len2: "num_gholes C = length ys"
  and Hole: "⋀x y. P GMHole [x] [y]"
  and Fun: "⋀f Cs xs ys.  sum_list (map num_gholes Cs) = length xs ⟹
    sum_list (map num_gholes Cs) = length ys ⟹
    (⋀i. i < length Cs ⟹ P (Cs ! i) (partition_gholes xs Cs ! i) (partition_gholes ys Cs ! i)) ⟹
    P (GMFun f Cs) (concat (partition_gholes xs Cs)) (concat (partition_gholes ys Cs))"
  shows "P C xs ys"
proof (insert len1 len2, induct C arbitrary: xs ys)
  case GMHole
  then show ?case using Hole by (cases xs; cases ys) auto
next
  case (GMFun f Cs)
  then show ?case using Fun[of Cs xs ys f] by (auto simp: length_partition_by_nth)
qed

lemma fill_gholes_induct[consumes 1, case_names GMHole GMFun]:
  fixes P :: "'f gmctxt ⇒ 'a list ⇒ bool"
  assumes len: "num_gholes C = length xs"
    and Hole: "⋀x. P GMHole [x]"
    and Fun: "⋀f Cs xs. sum_list (map num_gholes Cs) = length xs ⟹
      (⋀i. i < length Cs ⟹ P (Cs ! i) (partition_gholes xs Cs ! i)) ⟹
      P (GMFun f Cs) (concat (partition_gholes xs Cs))"
  shows "P C xs"
  using fill_gholes_induct2[of C xs xs "λ C xs _. P C xs"] assms by simp

lemma eq_gfill_induct [consumes 1, case_names GMHole GMFun]:
  assumes "t =Gf (C, ts)"
    and "⋀t. P t GMHole [t]"
    and "⋀f ss Cs ts. ⟦length Cs = length ss; sum_list (map num_gholes Cs) = length ts;
      ∀i < length ss. ss ! i =Gf (Cs ! i, partition_gholes ts Cs ! i) ∧
        P (ss ! i) (Cs ! i) (partition_gholes ts Cs ! i)⟧
      ⟹ P (GFun f ss) (GMFun f Cs) ts"
  shows "P t C ts" using assms(1)
proof (induct t arbitrary: C ts)
  case (GFun f ss)
  {assume "C = GMHole" and "ts = [GFun f ss]"
    then have ?case using assms(2) by auto}
  moreover
  {fix Cs
    assume C: "C = GMFun f Cs" and "sum_list (map num_gholes Cs) = length ts"
      and "length Cs = length ss"
      and "GFun f ss = fill_gholes (GMFun f Cs) ts"
    moreover then have "∀i < length ss. ss ! i =Gf (Cs ! i, partition_gholes ts Cs ! i)"
      by (auto simp del: fill_gholes.simps
         simp: partition_holes_fill_gholes_conv' length_partition_gholes_nth  intro!: eq_gfill.intros)
    moreover have "∀i < length ss. P (ss ! i) (Cs ! i) (partition_gholes ts Cs ! i)"
      using GFun calculation(5) nth_mem by blast
    ultimately have ?case using assms(3)[of Cs ss ts f] by auto}
  ultimately show ?case using GFun
    by (elim eq_gfill.cases) (auto simp del: fill_gholes.simps,
      metis GFun.prems eqgf_GMFunE eqgf_GMHoleE gterm.inject num_gholes.elims)
qed

lemma nempty_ground_mctxt_gmctxt [simp]:
  "C ≠ MHole ⟹ ground_mctxt C ⟹ gmctxt_of_mctxt C ≠ GMHole"
  by (induct C) auto

lemma mctxt_of_gmctxt_fill_holes [simp]:
  assumes "num_gholes C = length ss"
  shows "gterm_of_term (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss)) = fill_gholes C ss" using assms
  by (induct rule: fill_gholes_induct) auto

lemma mctxt_of_gmctxt_terms_fill_holes:
  assumes "num_gholes C = length ss"
  shows "gterm_of_term (fill_holes (mctxt_of_gmctxt C) ss) = fill_gholes C (map gterm_of_term ss)" using assms
  by (induct rule: fill_gholes_induct) auto

lemma ground_gmctxt_of_mctxt_gterm_fill_holes:
  assumes "num_holes C = length ss" and "ground_mctxt C"
  shows "term_of_gterm (fill_gholes (gmctxt_of_mctxt C) ss) = fill_holes C (map term_of_gterm ss)" using assms
  by (induct rule: fill_holes_induct)
   (auto simp: comp_def, metis (no_types, lifting) map_eq_conv num_gholes_gmctxt_of_mctxt)

lemma  ground_gmctxt_of_gterm_of_term:
  assumes "num_holes C = length ss" and "ground_mctxt C"
  shows "gterm_of_term (fill_holes C (map term_of_gterm ss)) = fill_gholes (gmctxt_of_mctxt C) ss" using assms
  by (induct rule: fill_holes_induct)
   (auto simp: comp_def, metis (no_types, lifting) map_eq_conv num_gholes_gmctxt_of_mctxt)

lemma ground_gmctxt_of_mctxt_fill_holes [simp]:
  assumes "num_holes C = length ss" and "ground_mctxt C" "∀ s ∈ set ss. ground s"  
  shows "term_of_gterm (fill_gholes (gmctxt_of_mctxt C) (map gterm_of_term ss)) = fill_holes C ss" using assms
  by (induct rule: fill_holes_induct) auto

lemma fill_holes_mctxt_of_gmctxt_to_fill_gholes:
  assumes "num_gholes C = length ss"
  shows "fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss) = term_of_gterm (fill_gholes C ss)"
  using assms
  by (metis ground_gmctxt_of_mctxt_gterm_fill_holes ground_mctxt_of_gmctxt mctxt_of_gmctxt_inv num_holes_mctxt_of_gmctxt)

lemma fill_gholes_gmctxt_of_gterm [simp]:
  "fill_gholes (gmctxt_of_gterm s) [] = s"
  by (induct s) (auto simp add: map_nth_eq_conv)

lemma fill_gholes_GMHole [simp]:
  "length ss = Suc 0 ⟹ fill_gholes GMHole ss = ss ! 0"
  by (cases ss) auto

lemma apply_gctxt_fill_gholes:
  "C⟨s⟩G = fill_gholes (gmctxt_of_gctxt C) [s]"
  by (induct C) (auto simp: partition_holes_fill_gholes_conv'
    simp del: fill_gholes.simps intro!: nth_equalityI)

lemma fill_gholes_apply_gctxt:
  "num_gholes C = Suc 0 ⟹ fill_gholes C [s] = (gctxt_of_gmctxt C)⟨s⟩G"
  by (simp add: apply_gctxt_fill_gholes gmctxt_of_gctxt_gctxt_of_gmctxt)


lemma ctxt_of_gctxt_gctxt_of_gmctxt_apply:
  "num_gholes C = Suc 0 ⟹ fill_holes (mctxt_of_gmctxt C) [s] = (ctxt_of_gctxt (gctxt_of_gmctxt C))⟨s⟩"
proof (induct C)
  case (GMFun f Cs)
  obtain i where split: "i < length Cs" "num_gholes (Cs ! i) = Suc 0"
    "∀ j < length Cs. j ≠ i ⟶ num_gholes (Cs ! j) = 0" using GMFun(2)
    by auto
  then have [simp]: "sum_list (take i (map num_gholes Cs)) = 0"
    by (auto simp: sum_list_eq_0_iff dest: set_take_nth)
  from split have [simp]: "j < length Cs ⟹ j ≠ i ⟹
     fill_holes (mctxt_of_gmctxt (Cs ! j)) [] = term_of_mctxt (mctxt_of_gmctxt (Cs ! j))" for j
    by (intro fill_holes_term_of_mctxt) auto
  from split have [simp]: "gctxt_of_gmctxt (GMFun f Cs) =
    GMore f (map gterm_of_gmctxt (take i Cs)) (gctxt_of_gmctxt (Cs ! i)) (map gterm_of_gmctxt (drop (Suc i) Cs))"
     using nth_length_takeWhile GMFun(2) sum_list_nthWhile_length by (auto simp: Let_def)
  show ?case using GMFun(1)[OF nth_mem[OF split(1)] split(2)] split
    by (auto simp: min_def nth_append_Cons partition_by_nth simp del: gctxt_of_gmctxt.simps intro!: nth_equalityI)
qed auto


lemma fill_gholes_replicate [simp]:
  "n = length ss ⟹ fill_gholes (GMFun f (replicate n GMHole)) ss = GFun f ss"
  unfolding partition_holes_fill_gholes_conv'
  by (induct ss arbitrary: n) auto

lemma fill_gholes_gmctxt_replicate_MHole [simp]:
  "fill_gholes_gmctxt C (replicate (num_gholes C) GMHole) = C"
proof (induct C)
  case (GMFun f Cs)
  {fix i assume "i < length Cs"
    then have "partition_gholes (replicate (sum_list (map num_gholes Cs)) GMHole) Cs ! i =
        replicate (num_gholes (Cs ! i)) GMHole"
      using partition_by_nth_nth[of "map num_gholes Cs" "replicate (sum_list (map num_gholes Cs)) MHole"]
      by (auto simp: length_partition_by_nth partition_by_nth_nth intro!: nth_equalityI)}
  note * = this
  show ?case using GMFun[OF nth_mem] by (auto simp: * intro!: nth_equalityI)
qed auto

lemma fill_gholes_gmctxt_GMFun_replicate_length [simp]:
  "fill_gholes_gmctxt (GMFun f (replicate (length Cs) GMHole)) Cs = GMFun f Cs"
  unfolding partition_holes_fill_gholes_gmctxt_conv'
  by (induct Cs) simp_all

lemma fill_gholes_gmctxt_MFun:
  assumes lCs: "length Cs = length ts"
    and lss: "length ss = length ts"
    and rec: "⋀ i. i < length ts ⟹ num_gholes (Cs ! i) = length (ss ! i) ∧
      fill_gholes_gmctxt (Cs ! i) (ss ! i) = ts ! i"
  shows "fill_gholes_gmctxt (GMFun f Cs) (concat ss) = GMFun f ts" 
  using assms unfolding fill_gholes_gmctxt.simps gmctxt.simps
  by (auto intro!: nth_equalityI)
    (metis length_map map_nth_eq_conv partition_by_concat_id)

lemma fill_gholes_gmctxt_nHole [simp]:
  "C ≠ GMHole ⟹ num_gholes C = length Ds ⟹ fill_gholes_gmctxt C Ds ≠ GMHole"
  using fill_gholes_gmctxt.elims by blast

lemma num_gholes_fill_gholes_gmctxt [simp]:
  assumes "num_gholes C = length Ds"
  shows "num_gholes (fill_gholes_gmctxt C Ds) = sum_list (map num_gholes Ds)" using assms
proof (induct C arbitrary: Ds)
  case GMHole then show ?case
    by (cases Ds) simp_all
next
  case (GMFun f Cs)
  then have *: "map (num_gholes ∘ (λi. fill_gholes_gmctxt (Cs ! i) (partition_gholes Ds Cs ! i))) [0..<length Cs] =
    map (λi. sum_list (map num_gholes (partition_gholes Ds Cs ! i))) [0 ..< length Cs]"
    and "sum_list (map num_gholes Cs) = length Ds"
    by (auto simp add: length_partition_by_nth)
  then show ?case
    using map_upt_len_conv [of "λx. sum_list (map num_gholes x)" "partition_gholes Ds Cs"]
    unfolding partition_holes_fill_holes_mctxt_conv by (simp add: *)
qed

lemma num_gholes_greater0_fill_gholes_gmctxt [intro!]:
  assumes "num_gholes C = length Ds"
    and "∃ D ∈ set Ds. 0 < num_gholes D"
  shows "0 < sum_list (map num_gholes Ds)"
  using assms gr_zeroI by force

lemma fill_gholes_gmctxt_fill_gholes:
  assumes len_ds: "length Ds = num_gholes C"
    and nh: "num_gholes (fill_gholes_gmctxt C Ds) = length ss"
  shows "fill_gholes (fill_gholes_gmctxt C Ds) ss =
  fill_gholes C [fill_gholes (Ds ! i) (partition_gholes ss Ds ! i). i ← [0 ..< num_gholes C]]"
  using assms(1)[symmetric] assms(2)
proof (induct C Ds arbitrary: ss rule: fill_gholes_induct)
  case (GMFun f Cs ds ss)
  define qs where "qs = map (λi. fill_gholes_gmctxt (Cs ! i) (partition_gholes ds Cs ! i)) [0..<length Cs]"
  then have qs: "⋀i. i < length Cs ⟹ fill_gholes_gmctxt (Cs ! i) (partition_gholes ds Cs ! i) = qs ! i"
    "length qs = length Cs" by auto
  define zs where "zs = map (λi. fill_gholes (ds ! i) (partition_gholes ss ds ! i)) [0..<length ds]"
  {fix i assume i: "i < length Cs"
    from GMFun(1) have *: "map length (partition_gholes ds Cs) = map num_gholes Cs" by auto
    have **: "length ss = sum_list (map sum_list (partition_gholes (map num_gholes ds) Cs))"
      using GMFun(1) GMFun(3)[symmetric] num_gholes_fill_gholes_gmctxt[of "GMFun f Cs" ds]
      by (auto simp: comp_def map_map_partition_by[symmetric])
    have "partition_by (partition_by ss
        (map (λi. num_gholes (fill_gholes_gmctxt (Cs ! i) (partition_gholes ds Cs ! i))) [0..<length Cs]) ! i)
        (partition_gholes (map num_gholes ds) Cs ! i) = partition_gholes (partition_gholes ss ds) Cs ! i"
      using i GMFun(1) GMFun(3) partition_by_partition_by[OF **]
      by (auto simp: comp_def num_gholes_fill_gholes_gmctxt length_partition_by_nth
        intro!: arg_cong[of _ _ "λx. partition_by (partition_by ss x ! _) _"] nth_equalityI)
    then have "map (λj. fill_gholes (partition_gholes ds Cs ! i ! j)
        (partition_gholes (partition_gholes ss qs ! i)
        (partition_gholes ds Cs ! i) ! j)) [0..<num_gholes (Cs ! i)] =
        partition_gholes zs Cs ! i" using GMFun(1,3)
      by (auto simp: length_partition_by_nth zs_def qs_def i comp_def partition_by_nth_nth intro: nth_equalityI)}
  then show ?case using GMFun
    by (simp add: qs_def [symmetric] qs zs_def [symmetric] length_partition_by_nth)
qed auto

lemma fill_gholes_gmctxt_sound:
  assumes len_ds: "length Ds = num_gholes C"
  and len_sss: "length sss = num_gholes C"
  and len_ts: "length ts = num_gholes C"
  and insts: "⋀ i. i < length Ds ⟹ ts ! i =Gf (Ds ! i, sss ! i)"
  shows "fill_gholes C ts =Gf (fill_gholes_gmctxt C Ds, concat sss)"
proof (rule eqfI)
  note l_nh_i = eqgfE(2)[OF insts]
  from len_ds len_sss have concat_sss: "partition_gholes (concat sss) Ds = sss"
    by (metis l_nh_i length_map map_nth_eq_conv partition_by_concat_id)
  then show nh: "num_gholes (fill_gholes_gmctxt C Ds) = length (concat sss)"
    unfolding num_gholes_fill_gholes_gmctxt [OF len_ds [symmetric]] length_concat
    by (metis l_nh_i len_ds len_sss nth_map_conv)
  have ts: "ts = [fill_gholes (Ds ! i) (partition_gholes (concat sss) Ds ! i) . i ← [0..<num_gholes C]]" (is "_ = ?fhs")
  proof (rule nth_equalityI)
    show l_fhs: "length ts = length ?fhs" unfolding length_map
      by (metis diff_zero len_ts length_upt)
    fix i
    assume i: "i < length ts"
    then have i': "i < length [0..<num_gholes C]" 
      by (metis diff_zero len_ts length_upt)
    show "ts!i = ?fhs ! i"
      unfolding nth_map[OF i']
      using eqgfE(1)[OF insts[unfolded len_ds, OF i[unfolded len_ts]]] 
      by (metis concat_sss i' len_ds len_sss map_nth nth_map)
  qed
  note ts = this
  show "fill_gholes C ts = fill_gholes (fill_gholes_gmctxt C Ds) (concat sss)"
    unfolding fill_gholes_gmctxt_fill_gholes[OF len_ds nh] ts ..
qed

subsubsection ‹Semilattice Structures›

lemma inf_gmctxt_idem [simp]:
  "(C :: 'f gmctxt) ⊓ C = C"
  by (induct C) (auto simp: zip_same_conv_map intro: map_idI)

lemma inf_gmctxt_GMHole2 [simp]:
  "C ⊓ GMHole = GMHole"
  by (induct C) simp_all

lemma inf_gmctxt_comm [ac_simps]:
  "(C :: 'f gmctxt) ⊓ D = D ⊓ C"
  by (induct C D rule: inf_gmctxt.induct) (fastforce simp: in_set_conv_nth intro!: nth_equalityI)+

lemma inf_gmctxt_assoc [ac_simps]:
  fixes C :: "'f gmctxt"
  shows "C ⊓ D ⊓ E = C ⊓ (D ⊓ E)"
  apply (induct C D arbitrary: E rule: inf_gmctxt.induct)
  apply (auto)
  apply (case_tac E, auto)+
  apply (fastforce simp: in_set_conv_nth intro!: nth_equalityI)
  apply (case_tac E, auto)+
done

instantiation gmctxt :: (type) order
begin

definition "(C :: 'a gmctxt) ≤ D ⟷ C ⊓ D = C"
definition "(C :: 'a gmctxt) < D ⟷ C ≤ D ∧ ¬ D ≤ C"

instance
  by (standard, simp_all add: less_eq_gmctxt_def less_gmctxt_def ac_simps, metis inf_gmctxt_assoc)

end

lemma less_eq_gmctxt_prime: "C ≤ D ⟷ less_eq_gmctxt C D"
proof
  assume "less_eq_gmctxt C D" then show "C ≤ D"
    by (induct C D rule: less_eq_gmctxt.induct) (auto simp: less_eq_gmctxt_def intro: nth_equalityI)
next
  assume "C ≤ D" then show "less_eq_gmctxt C D" unfolding less_eq_gmctxt_def
  by (induct C D rule: inf_gmctxt.induct)
     (auto split: if_splits simp: set_zip intro!: less_eq_gmctxt.intros nth_equalityI elim!: nth_equalityE, metis)
qed

lemmas less_eq_gmctxt_induct = less_eq_gmctxt.induct[folded less_eq_gmctxt_prime, consumes 1]
lemmas less_eq_gmctxt_intros = less_eq_gmctxt.intros[folded less_eq_gmctxt_prime]

lemma  less_eq_gmctxt_Hole:
  "less_eq_gmctxt C GMHole ⟹ C = GMHole"
  using less_eq_gmctxt.cases by blast

lemma num_gholes_at_least1:
  "0 < num_gholes C ⟹ 0 < num_gholes (C ⊓ D)"
proof (induct C arbitrary: D)
  case (GMFun f Cs)
  from GMFun(2) obtain i where wit: "i < length Cs" "0 < num_gholes (Cs ! i)"
    by (auto, metis (mono_tags, lifting) in_set_conv_nth length_map map_nth_eq_conv not_less sum_list_nonpos)
  note IS = GMFun(1)[OF nth_mem, OF wit]
  show ?case
  proof (cases D)
    case [simp]: (GMFun g Ds)
    {assume "f = g" "length Cs = length Ds"
      then have "0 < num_gholes (Cs ! i ⊓ Ds ! i)" using IS[of "Ds ! i"]
        by auto}
    then show ?thesis using wit(1)
      by (auto simp:  split!: prod.splits)
         (smt (verit, del_insts) length_map length_zip map_nth_eq_conv min_less_iff_conj not_gr0 nth_mem nth_zip o_apply prod.simps(2) sum_list_eq_0_iff) 
  qed auto
qed auto

text ‹
  @{const sup} is defined on compatible multihole contexts.
  Note that compatibility is not transitive.
›
instance gmctxt :: (type) semilattice_inf
  apply (standard)
  apply (auto simp: less_eq_gmctxt_def inf_gmctxt_assoc [symmetric])
  apply (metis inf_gmctxt_comm inf_gmctxt_assoc inf_gmctxt_idem)+
  done


lemma sup_gmctxt_idem [simp]:
  fixes C :: "'f gmctxt"
  shows "C ⊔ C = C"
  by (induct C) (auto simp: zip_same_conv_map intro: map_idI)

lemma sup_gmctxt_MHole [simp]: "C ⊔ GMHole = C"
  by (induct C) simp_all

lemma sup_gmctxt_comm [ac_simps]:
  fixes C :: "'f gmctxt"
  shows "C ⊔ D = D ⊔ C"
  by (induct C D rule: sup_gmctxt.induct) (fastforce simp: in_set_conv_nth intro!: nth_equalityI)+


lemma comp_gmctxt_refl:
  "(C, C) ∈ comp_gmctxt"
  by (induct C) auto

lemma comp_gmctxt_sym:
  assumes "(C, D) ∈ comp_gmctxt"
  shows "(D, C) ∈ comp_gmctxt"
  using assms by (induct) auto

lemma sup_gmctxt_assoc [ac_simps]:
  assumes "(C, D) ∈ comp_gmctxt" and "(D, E) ∈ comp_gmctxt"
  shows "C ⊔ D ⊔ E = C ⊔ (D ⊔ E)"
  using assms by (induct C D arbitrary: E) (auto elim!: comp_gmctxt.cases intro!: nth_equalityI)

text ‹
  No instantiation to @{class semilattice_sup} possible, since @{const sup} is only
  partially defined on terms (e.g., it is not associative in general).
›

interpretation gmctxt_order_bot: order_bot GMHole "(≤)" "(<)"
  by (standard) (simp add: less_eq_gmctxt_def)

lemma sup_gmctxt_ge1 [simp]:
  assumes "(C, D) ∈ comp_gmctxt"
  shows "C ≤ C ⊔ D"
  using assms by (induct C D) (auto simp: less_eq_gmctxt_def intro: nth_equalityI)

lemma sup_gmctxt_ge2 [simp]:
  assumes "(C, D) ∈ comp_gmctxt"
  shows "D ≤ C ⊔ D"
  using assms by (induct) (auto simp: less_eq_gmctxt_def intro: nth_equalityI)

lemma sup_gmctxt_least:
  assumes "(D, E) ∈ comp_gmctxt"
    and "D ≤ C" and "E ≤ C"
  shows "D ⊔ E ≤ C"
  using assms
  apply (induct arbitrary: C)
  apply (auto simp: less_eq_gmctxt_def elim!: inf_gmctxt.elims intro!: nth_equalityI)
  apply (metis (erased, lifting) length_map nth_map nth_zip split_conv)
  apply (case_tac "fb = gb ∧ length Csb = length Dsb", simp_all)+
  done

lemma sup_gmctxt_args_MHole2 [simp]:
  "sup_gmctxt_args C GMHole = replicate (num_gholes C) GMHole"
  by (cases C) simp_all

lemma num_gholes_sup_gmctxt_args:
  assumes "(C, D) ∈ comp_gmctxt"
  shows "num_gholes C = length (sup_gmctxt_args C D)"
  using assms by (induct) (auto simp: length_concat intro!: arg_cong [of _ _ sum_list] nth_equalityI)

lemma sup_gmctxt_sup_gmctxt_args:
  assumes "(C, D) ∈ comp_gmctxt"
  shows "fill_gholes_gmctxt C (sup_gmctxt_args C D) = C ⊔ D" using assms
proof (induct)
  note fill_gholes_gmctxt.simps [simp del]
  case (GMFun f g Cs Ds)
  then show ?case
  proof (cases "f = g ∧ length Cs = length Ds")
    case True
    with GMFun have "∀i < length Cs.
      fill_gholes_gmctxt (Cs ! i) (sup_gmctxt_args (Cs ! i) (Ds ! i)) = Cs ! i ⊔ Ds ! i"
      and *: "∀i < length Cs. (Cs ! i, Ds ! i) ∈ comp_gmctxt" by (force simp: set_zip)+
    moreover have "partition_gholes (concat (map (case_prod sup_gmctxt_args) (zip Cs Ds)))
      Cs = map (case_prod sup_gmctxt_args) (zip Cs Ds)"
      using True and * by (intro partition_by_concat_id) (auto simp: num_gholes_sup_gmctxt_args)
    ultimately show ?thesis
      using * and True by (auto simp: partition_holes_fill_gholes_gmctxt_conv intro!: nth_equalityI)
  qed auto
qed auto

lemma eqgf_comp_gmctxt:
  assumes "s =Gf (C, ss)" and "s =Gf (D, ts)"
  shows "(C, D) ∈ comp_gmctxt" using assms
proof (induct s arbitrary: C D ss ts)
  case (GFun f ss C D us vs)
  { fix Cs and Ds
    assume *: "C = GMFun f Cs" "D = GMFun f Ds" and **: "length Cs = length Ds"
    have ?case
    proof (unfold *, intro comp_gmctxt.GMFun [OF refl **] allI impI)
      fix i
      assume "i < length Ds" then show "(Cs ! i, Ds ! i) ∈ comp_gmctxt"
        using GFun by (auto simp: * ** elim!: eqgf_GMFunE) (metis nth_mem)
    qed}
  from GFun.prems this show ?case
  by (cases C D rule: gmctxt.exhaust [case_product gmctxt.exhaust])
    (auto simp: eq_gfill.simps dest: map_eq_imp_length_eq)
qed

lemma eqgf_less_eq [simp]:
  assumes "s =Gf (C, ss)"
  shows "C ≤ gmctxt_of_gterm s" using assms
  by (induct rule: eq_gfill_induct) (auto simp: less_eq_gmctxt_prime)

lemma less_eq_comp_gmctxt [simp]:
  "C ≤ D ⟹ (C, D) ∈ comp_gmctxt"
  by (induct rule: less_eq_gmctxt_induct) auto

lemma gmctxt_less_eq_sup:
  "(C :: 'f gmctxt) ≤ D ⟹ C ⊔ D = D"
  by (induct rule: less_eq_gmctxt_induct) (auto intro: nth_equalityI)

lemma fill_gholes_gmctxt_less_eq:
  assumes "num_gholes C = length Ds"
  shows "C ≤ fill_gholes_gmctxt C Ds" using assms
proof (induct C arbitrary: Ds)
  case (GMFun f Cs)
  show ?case using GMFun(1)[OF nth_mem] GMFun(2)
    unfolding partition_holes_fill_gholes_gmctxt_conv'
    by (intro less_eq_gmctxt_intros) (auto simp: length_partition_by_nth)
qed simp


lemma less_eq_to_sup_mctxt_args [elim]:
  assumes "C ≤ D"
  obtains Ds where "num_gholes C = length Ds" "D = fill_gholes_gmctxt C Ds"
  using assms gmctxt_less_eq_sup[OF assms]
  using sup_gmctxt_sup_gmctxt_args[OF less_eq_comp_gmctxt[OF assms]]
  using less_eq_comp_gmctxt num_gholes_sup_gmctxt_args
  by force
  
lemma fill_gholes_gmctxt_sup_mctxt_args [simp]:
  assumes "num_gholes C = length Ds"
  shows "sup_gmctxt_args C (fill_gholes_gmctxt C Ds) = Ds" using assms
proof (induct C arbitrary: Ds)
  case GMHole then show ?case
    by (cases Ds) auto
next
  case (GMFun f Cs)
  have "map2 sup_gmctxt_args Cs (map2 fill_gholes_gmctxt Cs (partition_gholes Ds Cs)) = partition_gholes Ds Cs"
    using GMFun(1)[OF nth_mem] GMFun(2)
    by (auto simp: length_partition_by_nth intro!: nth_equalityI)
  then show ?case using GMFun(1)[OF nth_mem] GMFun(2)
    unfolding partition_holes_fill_gholes_gmctxt_conv'
    using concat_partition_by[of "map num_gholes Cs" Ds]
    by auto
qed

lemma map2_fill_gholes_gmctxt_id [simp]:
  assumes "⋀ i. i < length Ds ⟹ num_gholes (Ds ! i) = 0"
  shows "map2 fill_gholes_gmctxt Ds (replicate (length Ds) []) = Ds"
  using assms fill_gholes_gmctxt_no_holes[of "Ds ! i" for i]
  by (auto simp: map_nth_eq_conv)

lemma fill_gholes_gmctxt_GMFun_replicate_append [simp]:
  assumes "length Cs = n" and "⋀ t. t ∈ set Ds ⟹ num_gholes t = 0"
  shows "fill_gholes_gmctxt (GMFun f ((replicate n GMHole) @ Ds)) Cs = GMFun f (Cs @ Ds)" using assms
proof (induct n arbitrary: Cs)
  case 0 note [simp] = 0(1)
  have "i < length Ds ⟹ num_gholes (Ds ! i) = 0" for i using 0 by fastforce
  then show ?case using 0 unfolding partition_holes_fill_gholes_gmctxt_conv'
    by (cases Cs) auto
next
  case (Suc n) then show ?case unfolding partition_holes_fill_gholes_gmctxt_conv'
    by (simp add: Cons_nth_drop_Suc take_Suc_conv_app_nth)
qed

lemma finite_ghole_poss:
  "finite (ghole_poss C)"
  by (induct C) auto

lemma ghole_poss_simp [simp]:
  "ghole_poss (GMFun f cs) = {i # p | i p. i < length cs ∧ p ∈ ghole_poss (cs ! i)}" by auto
declare ghole_poss.simps(2)[simp del]

lemma num_gholes_zero_ghole_poss:
  "num_gholes D = 0 ⟹ ghole_poss D = {}"
  by (induct D) auto

lemma ghole_poss_num_gholes_zero:
  "ghole_poss D = {} ⟹ num_gholes D = 0"
proof (induct D)
  case (GMFun f Ds)
  then show ?case
    by (simp, metis Collect_empty_eq Collect_mem_eq in_set_idx)
qed simp

lemma num_ghloes_nzero_ghole_poss_nempty:
  "num_gholes D ≠ 0 ⟹ ghole_poss D ≠ {}"
  by (induct D) (auto simp: in_set_conv_nth, fastforce)

lemma ghole_poss_epsE [elim]:
  "ghole_poss D = {[]} ⟹ D = GMHole"
  by (induct D) auto

lemma ghole_poss_gmctxt_of_gterm [simp]:
  "ghole_poss (gmctxt_of_gterm t) = {}"
  by (induct t) auto

lemma ghole_poss_subseteq_args [simp]:
  assumes "ghole_poss (GMFun f Ds) ⊆ ghole_poss (GMFun g Cs)"
  shows "∀ i < min (length Ds) (length Cs). ghole_poss (Ds ! i) ⊆ ghole_poss (Cs ! i)" using assms
  by auto

lemma factor_ghole_pos_by_prefix:
  assumes "C ≤ D" "p ∈ ghole_poss D"
  obtains q where "q ≤p p" "q ∈ ghole_poss C"
  using assms
  by (induct C D arbitrary: p thesis rule: less_eq_gmctxt_induct)
     (auto, metis position_less_eq_Cons)

lemma prefix_and_fewer_gholes_implies_equal_gmctxt:
  "C ≤ D ⟹ ghole_poss C ⊆ ghole_poss D ⟹ C = D"
proof (induct C D rule: less_eq_gmctxt_induct)
  case (1 D) then show ?case by (cases D) auto
next
  case (2 Cs Ds f)
  have "i < length Ds ⟹ ghole_poss (Cs ! i) ⊆ ghole_poss (Ds ! i)" for i using 2(1,4) by auto
  then show ?case using 2 by (auto intro!: nth_equalityI)
qed

lemma set_sup_gmctxt_args_split:
  "length Cs = length Ds ⟹ set (sup_gmctxt_args (GMFun f Cs) (GMFun f Ds)) =
     (⋃ i ∈ {0..< length Ds}. set (sup_gmctxt_args (Cs ! i) (Ds ! i)))"
  by (auto simp: atLeast0LessThan in_set_zip)
    (metis length_map map_fst_zip nth_mem nth_zip)

lemma gmctxt_closing_trans:
  "gmctxt_closing C D ⟹ gmctxt_closing D E ⟹ gmctxt_closing C E"
  unfolding gmctxt_closing_def using less_eq_gmctxt_prime
  by (metis (full_types) order_trans)

lemma gmctxt_closing_sup_args_ghole_or_gterm:
  assumes "gmctxt_closing C D"
  shows "∀ E ∈ set (sup_gmctxt_args C D). E = GMHole ∨ num_gholes E = 0"
  using assms unfolding gmctxt_closing_def
proof -
  from assms have "C ≤ D" "ghole_poss D ⊆ ghole_poss C" unfolding gmctxt_closing_def
    by (auto simp: less_eq_gmctxt_prime)
  then show ?thesis
  proof (induct rule: less_eq_gmctxt_induct)
    case (1 D)
    then show ?case
      by (cases D) (auto simp: in_set_conv_nth intro!: ghole_poss_num_gholes_zero, blast)
  next
    case (2 cs ds f) note IS = this
    show ?case using IS set_sup_gmctxt_args_split[OF IS(1)]
      by auto
  qed
qed

lemma inv_imples_ghole_poss_subseteq:
  "C ≤ D ⟹ ∀ E ∈ set (sup_gmctxt_args C D). E = GMHole ∨ num_gholes E = 0 ⟹ ghole_poss D ⊆ ghole_poss C"
proof (induct rule: less_eq_gmctxt_induct)
  case (1 D) then show ?case
    by (cases D) (auto simp: num_gholes_zero_ghole_poss)
next
  case (2 cs ds f)
  then show ?case using set_sup_gmctxt_args_split[OF 2(1)]
    by auto (metis (no_types, lifting) fst_conv in_set_zip snd_conv subsetD)
qed

lemma fill_gholes_gmctxt_ghole_poss_subseteq:
  assumes "num_gholes C = length Ds" "∀ i < length Ds. Ds ! i = GMHole ∨ num_gholes (Ds ! i) = 0"
  shows "ghole_poss (fill_gholes_gmctxt C Ds) ⊆ ghole_poss C" using assms
proof (induct rule: fill_gholes_induct)
  case (GMFun f Cs xs)
  then show ?case unfolding partition_holes_fill_gholes_gmctxt_conv'
    by auto (metis (no_types, lifting) length_map length_partition_by_nth partition_by_nth_nth(1, 2) subsetD)
qed (auto simp: num_gholes_zero_ghole_poss)

lemma ghole_poss_not_in_poss_gmctxt:
  assumes "p ∈ ghole_poss C"
  shows "p ∉ poss_gmctxt C" using assms
  by (induct C arbitrary: p) auto

lemma comp_gmctxt_inf_ghole_poss_cases:
  assumes "(C, D) ∈ comp_gmctxt" "p ∈ ghole_poss (C ⊓ D)"
  shows "p ∈ ghole_poss C ∧ p ∈ ghole_poss D ∨
    p ∈ ghole_poss C ∧ p ∈ poss_gmctxt D ∨
    p ∈ ghole_poss D ∧ p ∈ poss_gmctxt C" using assms
proof (induct arbitrary: p)
  case (GMHole1 D) then show ?case
    by (cases D) auto
next
  case (GMHole2 C) then show ?case
    by (cases C) auto
next
  case (GMFun f g Cs Ds)
  then show ?case
    by (auto simp: atLeast0LessThan) blast+
qed

lemma length_ghole_poss_list_num_gholes:
  "num_gholes C = length (ghole_poss_list C)"
  by (induct C) (auto simp: length_concat intro: nth_sum_listI)

lemma ghole_poss_list_distict:
  "distinct (ghole_poss_list C)"
proof (induct C)
  case (GMFun f Cs)
  then show ?case proof (induct Cs rule: rev_induct)
    case (snoc x xs)
    then have "distinct (ghole_poss_list (GMFun f xs))" "distinct (ghole_poss_list x)" by auto
    then show ?case using snoc by (auto simp add: map_cons_presv_distinct dest: set_zip_leftD)
  qed auto
qed auto

lemma ghole_poss_ghole_poss_list_conv:
  "ghole_poss C = set (ghole_poss_list C)"
proof (induct C)
  case (GMFun f Cs) note IS = GMFun[OF nth_mem]
  {fix p assume "p ∈ ghole_poss (GMFun f Cs)"
    then obtain i ps where w: "p = i # ps" "i < length Cs"
      "ps ∈ ghole_poss (Cs ! i)" by auto
    then have "(i, Cs ! i) ∈ set (zip [0..<length Cs] Cs)"
      by (force simp: in_set_zip)
    then have "p ∈ set (ghole_poss_list (GMFun f Cs))" using IS[of i] w
      by auto}
  then show ?case using IS
    by (auto simp: in_set_zip)
qed auto

lemma card_ghole_poss_num_gholes:
  "card (ghole_poss C) = num_gholes C"
  unfolding ghole_poss_ghole_poss_list_conv
  unfolding length_ghole_poss_list_num_gholes
  using ghole_poss_list_distict
  using distinct_card by blast

lemma subgm_at_hole_poss [simp]:
  "p ∈ ghole_poss C ⟹ subgm_at C p = GMHole"
  by (induct C arbitrary: p) auto

lemma subgm_at_mctxt_of_term:
  "p ∈ gposs t ⟹ subgm_at (gmctxt_of_gterm t) p = gmctxt_of_gterm (gsubt_at t p)"
  by (induct t arbitrary: p) auto

lemma num_gholes_subgm_at:
  assumes "p ∈ poss_gmctxt C"
  shows "num_gholes (subgm_at C p) = ghole_num_at_pos p C" using assms
  by (induct C arbitrary: p) auto

lemma gmctxt_subtgm_at_fill_args_empty_pos [simp]:
  assumes "num_gholes C = length ts"
  shows "gmctxt_subtgm_at_fill_args [] C ts = ts"
  using assms by (auto simp: gmctxt_subtgm_at_fill_args_def)

lemma ghole_num_bef_at_pos_num_gholes_less_eq:
  assumes "p ∈ poss_gmctxt C"
  shows "ghole_num_bef_pos p C + ghole_num_at_pos p C ≤ num_gholes C" using assms
proof (induct C arbitrary: p)
  case (GMFun f Cs)
  show ?case 
  proof (cases p)
    case (Cons i ps)
    have *: "num_gholes (GMFun f Cs) = sum_list (map num_gholes (take i Cs)) + num_gholes (Cs ! i) + sum_list (map num_gholes (drop (Suc i) Cs))"
      using GMFun(2) unfolding Cons
      by (auto simp flip: take_map take_drop)
         (metis Cons_nth_drop_Suc add.assoc append_take_drop_id drop_map length_map nth_map sum_list.Cons sum_list.append)
    from Cons have
      "(sum_list (map num_gholes (take i Cs)) + (ghole_num_bef_pos ps (Cs ! i) + ghole_num_at_pos ps (Cs ! i)))
       + sum_list (map num_gholes (drop (Suc i) Cs)) ≤
       (sum_list (map num_gholes (take i Cs)) + num_gholes (Cs ! i)) + sum_list (map num_gholes (drop (Suc i) Cs))"
      using GMFun(1)[OF nth_mem, of i ps] GMFun(2)
      by auto
    from add_le_imp_le_right[OF this] show ?thesis using GMFun(2) *
      unfolding Cons
      by simp
  qed auto
qed auto

lemma ghole_num_at_pos_fill_args_length:
  assumes "p ∈ poss_gmctxt C" "num_gholes C = length ts"
  shows "ghole_num_at_pos p C = length (gmctxt_subtgm_at_fill_args p C ts)"
  using ghole_num_bef_at_pos_num_gholes_less_eq[OF assms(1)] assms(2)
  by (auto simp: gmctxt_subtgm_at_fill_args_def)

lemma ghole_poss_nth_subt_at:
  assumes "t =Gf (C, ts)" and "p ∈ ghole_poss C"
  shows "ghole_num_bef_pos p C < length ts ∧ gsubt_at t p = ts ! ghole_num_bef_pos p C" using assms
proof (induct arbitrary: p rule: eq_gfill_induct)
  case (GMFun f ss Cs ts)
  let ?ts = "partition_gholes ts Cs"
  from GMFun obtain i and q where [simp]: "p = i # q"
    and "i < length ss" and "q ∈ ghole_poss (Cs ! i)" by auto
  with GMFun.hyps have "ss ! i =Gf (Cs ! i, ?ts ! i)"
    and j: "ghole_num_bef_pos q (Cs ! i) < length (?ts ! i)" (is "?j < length _")
    and *: "?ts ! i ! ghole_num_bef_pos q (Cs ! i) = gsubt_at (ss ! i) q"
    by auto
  let ?k = "sum_list (map length (take i ?ts)) + ?j"
  have "i < length ?ts" using ‹i < length ss› and GMFun by auto
  with partition_by_nth_nth_old [OF this j] and GMFun and concat_nth_length [OF this j]
    have "?ts ! i ! ?j = ts ! ?k" and "?k < length ts" by (auto)
  moreover with * have "ts ! ?k = gsubt_at (GFun f ss) p" using ‹i < length ss› by simp
  ultimately show ?case using GMFun.hyps(2) by (auto simp: take_map [symmetric])
qed auto

lemma poss_gmctxt_fill_gholes_split:
  assumes "t =Gf (C, ts)" and "p ∈ poss_gmctxt C"
  shows "gsubt_at t p =Gf (subgm_at C p , gmctxt_subtgm_at_fill_args p C ts)"
  using assms
proof (induct arbitrary: p rule: eq_gfill_induct)
  case (GMFun f ss Cs ts)
  let ?ts = "partition_gholes ts Cs"
  from GMFun have "⋀ i. i < length Cs ⟹ ss ! i =Gf (Cs ! i, ?ts ! i)" by auto
  show ?case
  proof (cases p)
    case Nil
    then have "GFun f ss =Gf (GMFun f Cs, concat ?ts)" using GMFun
      by (intro eqgf_GMFunI) (auto simp del: fill_gholes.simps)
    then show ?thesis using GMFun unfolding Nil
      by simp
  next
    case (Cons i q)
    then have "ghole_num_at_pos q (Cs ! i) ≤ num_gholes (Cs ! i) - ghole_num_bef_pos q (Cs ! i)"
      using GMFun(1, 2, 4) ghole_num_bef_at_pos_num_gholes_less_eq[of q "Cs ! i"]
      by auto
    then show ?thesis using GMFun
      by (auto simp: Cons add.commute gmctxt_subtgm_at_fill_args_def partition_by_nth drop_take take_map min_def split!: if_splits)
  qed
qed auto

lemma fill_gholes_ghole_poss:
  assumes "t =Gf (C, ts)" and "i < length ts"
  shows "gsubt_at t (ghole_poss_list C ! i) = ts ! i" using assms
proof (induct arbitrary: i rule: eq_gfill_induct)
  case (GMFun f ss Cs ts)
  have *: "length (concat (poss_rec ghole_poss_list Cs)) = num_gholes (GMFun f Cs)"
    using GMFun(1, 2, 4)
    unfolding length_ghole_poss_list_num_gholes[of "GMFun f Cs", symmetric, unfolded ghole_poss_list.simps]
    by auto
  from GMFun have b: "i < length (concat (partition_gholes ts Cs))" by simp
  then have ts: "ts ! i = (λ (j, k). partition_gholes ts Cs ! j ! k) (concat_index_split (0, i) (partition_gholes ts Cs))"
    by (metis GMFun.hyps(2) concat_index_split_sound concat_partition_by)
  obtain o_idx i_idx where csp: "concat_index_split (0, i) (partition_gholes ts Cs) = (o_idx, i_idx)"
    using old.prod.exhaust by blast
  have idx: "o_idx < length Cs" "i_idx < length (partition_gholes ts Cs ! o_idx)"
    using concat_index_split_sound_bounds[OF b csp] by auto
  have "concat_index_split (0, i) (poss_rec ghole_poss_list Cs) = (o_idx, i_idx)"
    using GMFun(1, 2, 4) * unfolding csp[symmetric]
    by (intro concat_index_split_unique, unfold *)
       (auto, simp add: length_ghole_poss_list_num_gholes length_partition_gholes_nth)
  then have gp: "ghole_poss_list (GMFun f Cs) ! i = poss_rec ghole_poss_list Cs ! o_idx ! i_idx"
    by (simp add: "*" GMFun.hyps(2) GMFun.prems concat_index_split_less_length_concat(4))
  from idx GMFun have r: "o_idx < length (zip [0..<length ss] Cs)" by auto
  then show ?case using GMFun idx unfolding ts csp gp
    by (auto simp: nth_map[OF r] length_ghole_poss_list_num_gholes length_partition_gholes_nth split: prod.splits)
qed auto

lemma length_unfill_gholes [simp]:
  assumes "C ≤ gmctxt_of_gterm t"
  shows "length (unfill_gholes C t) = num_gholes C"
  using assms
proof (induct C t rule: unfill_gholes.induct)
  case (2 f Cs g ts) with 2(1)[OF _ nth_mem] 2(2) show ?case
    by (auto simp: less_eq_gmctxt_def length_concat
      intro!: cong[of sum_list, OF refl] nth_equalityI elim!: nth_equalityE)
qed auto

lemma fill_gholes_arbitrary:
  assumes lCs: "length Cs = length ts"
    and lss: "length ss = length ts"
    and rec: "⋀ i. i < length ts ⟹ num_gholes (Cs ! i) = length (ss ! i) ∧ f (Cs ! i) (ss ! i) = ts ! i"
  shows "map (λi. f (Cs ! i) (partition_gholes (concat ss) Cs ! i)) [0 ..< length Cs] = ts"
proof -
  have "sum_list (map num_gholes Cs) = length (concat ss)" using assms
    by (auto simp: length_concat map_nth_eq_conv intro: arg_cong[of _ _ "sum_list"])
  moreover have "partition_gholes (concat ss) Cs = ss"
    using assms by (auto intro: partition_by_concat_id)
  ultimately show ?thesis using assms by (auto intro: nth_equalityI)
qed

lemma fill_unfill_gholes:
  assumes "C ≤ gmctxt_of_gterm t"
  shows "fill_gholes C (unfill_gholes C t) = t"
  using assms
proof (induct C t rule: unfill_gholes.induct)
  case (2 f Cs g ts) with 2(1)[OF _ nth_mem] 2(2) show ?case
    by (auto simp: less_eq_gmctxt_def unfill_gholes_conv intro!: fill_gholes_arbitrary elim!: nth_equalityE)
qed (auto split: if_splits)

lemma funas_gmctxt_of_mctxt [simp]:
  "ground_mctxt C ⟹ funas_gmctxt (gmctxt_of_mctxt C) = funas_mctxt C"
  by (induct C) (auto simp: funas_gterm_gterm_of_term)

lemma funas_mctxt_of_gmctxt_conv:
  "funas_mctxt (mctxt_of_gmctxt C) = funas_gmctxt C"
  by (induct C) (auto simp flip: funas_gterm_gterm_of_term)

lemma funas_gterm_ctxt_apply [simp]:
  assumes "num_gholes C = length ss"
  shows "funas_gterm (fill_gholes C ss) = funas_gmctxt C ∪ ⋃ (set (map funas_gterm ss))" using assms
proof (induct rule: fill_gholes_induct)
  case (GMFun f Cs ss)
  show ?case using GMFun partition_gholes_subseteq[OF GMFun(1)]
    by (auto simp add: Un_Union_image simp del: map_partition_by_nth)
qed simp

lemma funas_gmctxt_gmctxt_of_gterm [simp]:
  "funas_gmctxt (gmctxt_of_gterm s) = funas_gterm s"
  by (induct s) auto

lemma funas_gmctxt_replicate_GMHole [simp]:
  "funas_gmctxt (GMFun f (replicate n GMHole)) = {(f, n)}"
  by auto

lemma funas_gmctxt_gmctxt_of_gctxt [simp]:
  "funas_gmctxt (gmctxt_of_gctxt C) = funas_gctxt C"
  by (induct C) auto

lemma funas_gmctxt_fill_gholes_gmctxt [simp]:
  assumes "num_gholes C = length Ds"
  shows "funas_gmctxt (fill_gholes_gmctxt C Ds) = funas_gmctxt C ∪ ⋃(set (map funas_gmctxt Ds))"
  (is "?f C Ds = ?g C Ds") using assms
proof (induct C arbitrary: Ds)
  case GMHole then show ?case by (cases Ds) simp_all
next
  case (GMFun f Cs)
  then have num_gholes: "sum_list (map num_gholes Cs) = length Ds" by simp
  let ?ys = "partition_gholes Ds Cs"
  have "⋀i. i < length Cs ⟹ ?f (Cs ! i) (?ys ! i) = ?g (Cs ! i) (?ys ! i)"
    by (simp add: GMFun.hyps length_partition_by_nth num_gholes)
  then have "(⋃i ∈ {0 ..< length Cs}. ?f (Cs ! i) (?ys ! i)) =
    (⋃i ∈ {0 ..< length Cs}. ?g (Cs ! i) (?ys ! i))" by simp
  then show ?case
    using num_gholes unfolding partition_holes_fill_holes_mctxt_conv
    by (simp add: UN_Un_distrib UN_upt_len_conv [of _ _ "λx. ⋃(set x)"] UN_set_partition_by_map)
qed

lemma funas_supremum:
  "C ≤ D ⟹ funas_gmctxt D = funas_gmctxt C ∪ ⋃ (set (map funas_gmctxt (sup_gmctxt_args C D)))"
  using fill_gholes_gmctxt_sup_mctxt_args[of C]
  by (auto simp: fill_gholes_gmctxt_sup_mctxt_args[of C] elim!: less_eq_to_sup_mctxt_args[of C D])

lemma funas_gctxt_gctxt_of_gmctxt [simp]:
  "num_gholes D = Suc 0 ⟹ funas_gctxt (gctxt_of_gmctxt D) = funas_gmctxt D"
  by (metis One_nat_def funas_gmctxt_gmctxt_of_gctxt gmctxt_of_gctxt_gctxt_of_gmctxt)

lemma funas_gterm_gterm_of_gmctxt [simp]:
  "num_gholes C = 0 ⟹ funas_gterm (gterm_of_gmctxt C) = funas_gmctxt C"
  by (metis funas_gmctxt_gmctxt_of_gterm no_gholes_gmctxt_of_gterm_gterm_of_gmctxt_id)

lemma less_sup_gmctxt_args_funas_gmctxt:
  "C ≤ D ⟹ funas_gmctxt C ⊆ ℱ ⟹ ∀ Ds ∈ set (sup_gmctxt_args C D). funas_gmctxt Ds ⊆ ℱ ⟹ funas_gmctxt D ⊆ ℱ"
  using funas_supremum[of C D] by auto

lemma funas_gmctxt_poss_gmctxt_subgm_at_funas:
  assumes "funas_gmctxt C ⊆ ℱ"  "p ∈ poss_gmctxt C"
  shows "funas_gmctxt (subgm_at C p) ⊆ ℱ"
  using assms
proof (induct C arbitrary: p)
  case (GMFun f Cs)
  then show ?case
    by (auto, blast) (metis SUP_le_iff nth_mem subsetD)
qed auto

lemma inf_funas_gmctxt_subset1:
  "funas_gmctxt (C ⊓ D) ⊆ funas_gmctxt C"
  using funas_supremum[of C "C ⊓ D"]
  by (metis funas_supremum inf_le1 le_sup_iff order_refl)

lemma inf_funas_gmctxt_subset2:
  "funas_gmctxt (C ⊓ D) ⊆ funas_gmctxt D"
  using funas_supremum[of D "C ⊓ D"]
  by (metis funas_supremum inf_le2 le_sup_iff order_refl)


end

Theory Bot_Terms

theory Bot_Terms
  imports Utils
begin

subsection ‹Bottom terms›

datatype 'f bot_term = Bot | BFun 'f (args: "'f bot_term list")

fun term_to_bot_term :: "('f, 'v) term ⇒ 'f bot_term"  ("_⊥" [80] 80) where
  "(Var _)⊥ = Bot"
| "(Fun f ts)⊥ = BFun f (map term_to_bot_term ts)"

fun root_bot where
  "root_bot Bot = None" |
  "root_bot (BFun f ts) = Some (f, length ts)"

fun funas_bot_term where
  "funas_bot_term Bot = {}"
| "funas_bot_term (BFun f ss) = {(f, length ss)} ∪ (⋃ (funas_bot_term ` set ss))"

lemma finite_funas_bot_term:
  "finite (funas_bot_term t)"
  by (induct t) auto

lemma funas_bot_term_funas_term:
  "funas_bot_term (t⊥) = funas_term t"
  by (induct t) auto

lemma term_to_bot_term_root_bot [simp]:
  "root_bot (t⊥) = root t"
  by (induct t) auto

lemma term_to_bot_term_root_bot_comp [simp]:
  "root_bot ∘ term_to_bot_term = root"
  using term_to_bot_term_root_bot by force

inductive_set mergeP where
  base_l [simp]: "(Bot, t) ∈ mergeP"
| base_r [simp]: "(t, Bot) ∈ mergeP"
| step [intro]: "length ss = length ts ⟹ (∀ i < length ts. (ss ! i, ts ! i) ∈ mergeP) ⟹
    (BFun f ss, BFun f ts) ∈ mergeP"

lemma merge_refl:
  "(s, s) ∈ mergeP"
  by (induct s) auto

lemma merge_symmetric:
  assumes "(s, t) ∈ mergeP"
  shows "(t, s) ∈ mergeP"
  using assms by induct auto

fun merge_terms :: "'f bot_term ⇒ 'f bot_term ⇒ 'f bot_term"  (infixr "↑" 67) where
  "Bot ↑ s = s"
| "s ↑ Bot = s"
| "(BFun f ss) ↑ (BFun g ts) = (if f = g ∧ length ss = length ts
     then BFun f (map (case_prod (↑)) (zip ss ts))
     else undefined)"

lemma merge_terms_bot_rhs[simp]:
  "s ↑ Bot = s" by (cases s) auto

lemma merge_terms_idem: "s ↑ s = s"
  by (induct s) (auto simp add: map_nth_eq_conv)

lemma merge_terms_assoc [ac_simps]:
  assumes "(s, t) ∈ mergeP" and "(t, u) ∈ mergeP"
  shows "(s ↑ t) ↑ u = s ↑ t ↑ u"
  using assms by (induct s t arbitrary: u) (auto elim!: mergeP.cases intro!: nth_equalityI)

lemma merge_terms_commutative [ac_simps]:
  shows "s ↑ t = t ↑ s"
  by (induct s t rule: merge_terms.induct)
   (fastforce simp: in_set_conv_nth intro!: nth_equalityI)+

lemma merge_dist:
  assumes "(s, t ↑ u) ∈ mergeP" and "(t, u) ∈ mergeP"
  shows "(s, t) ∈ mergeP" using assms
  by (induct t arbitrary: s u) (auto elim!: mergeP.cases, metis mergeP.step nth_mem)

lemma megeP_ass:
  "(s, t ↑ u) ∈ mergeP ⟹ (t, u) ∈ mergeP ⟹ (s ↑ t, u) ∈ mergeP"
  by (induct t arbitrary: s u) (auto simp: mergeP.step elim!: mergeP.cases)

inductive_set bless_eq where
  base_l [simp]: "(Bot, t) ∈ bless_eq"
| step [intro]: "length ss = length ts ⟹ (∀ i < length ts. (ss ! i, ts ! i) ∈ bless_eq) ⟹
  (BFun f ss, BFun f ts) ∈ bless_eq"

text ‹Infix syntax.›
abbreviation "bless_eq_pred s t ≡ (s, t) ∈ bless_eq"
notation
  bless_eq ("{≤b}") and
  bless_eq_pred ("(_/ ≤b _)" [56, 56] 55)

lemma BFun_leq_Bot_False [simp]:
  "BFun f ts ≤b Bot ⟷ False"
  using bless_eq.cases by auto

lemma BFun_lesseqE [elim]:
  assumes "BFun f ts ≤b t"
  obtains us where "length ts = length us" "t = BFun f us"
  using assms bless_eq.cases by blast

lemma bless_eq_refl: "s ≤b s"
  by (induct s) auto

lemma bless_eq_trans [trans]:
  assumes "s ≤b t" and "t ≤b u"
  shows "s ≤b u" using assms
proof (induct arbitrary: u)
  case (step ss ts f)
  from step(3) obtain us where [simp]: "u = BFun f us" "length ts = length us" by auto
  from step(3, 1, 2) have "i < length ss ⟹ ss ! i ≤b us ! i" for i
    by (cases rule: bless_eq.cases) auto
  then show ?case using step(1) by auto
qed auto

lemma bless_eq_anti_sym:
  "s ≤b t ⟹ t ≤b s ⟹ s = t"
  by (induct rule: bless_eq.induct) (auto elim!: bless_eq.cases intro: nth_equalityI)

lemma bless_eq_mergeP:
  "s ≤b t ⟹ (s, t) ∈ mergeP"
  by (induct s arbitrary: t) (auto elim!: bless_eq.cases)

lemma merge_bot_args_bless_eq_merge:
  assumes "(s, t) ∈ mergeP"
  shows "s ≤b s ↑ t" using assms
  by (induct s arbitrary: t) (auto simp: bless_eq_refl elim!: mergeP.cases intro!: step)

lemma bless_eq_closued_under_merge:
  assumes "(s, t) ∈ mergeP" "(u, v) ∈ mergeP" "s ≤b u" "t ≤b v"
  shows "s ↑ t ≤b u ↑ v" using assms(3, 4, 1, 2)
proof (induct arbitrary: t v)
  case (base_l t)
  then show ?case using bless_eq_trans merge_bot_args_bless_eq_merge
    by (metis merge_symmetric merge_terms.simps(1) merge_terms_commutative) 
next
  case (step ss ts f)
  then show ?case apply (auto elim!: mergeP.cases intro!: bless_eq.step)
    using bless_eq_trans merge_bot_args_bless_eq_merge apply blast
    by (metis bless_eq.cases bot_term.distinct(1) bot_term.sel(2))
qed

lemma bless_eq_closued_under_supremum:
  assumes "s ≤b u" "t ≤b u"
  shows "s ↑ t ≤b u" using assms
  by (induct arbitrary: t) (auto elim!: bless_eq.cases intro!: bless_eq.step)

lemma linear_term_comb_subst:
  assumes "linear_term (Fun f ss)"
    and "length ss = length ts"
    and "⋀ i. i < length ts ⟹ ss ! i ⋅ σ i = ts ! i"
  shows "∃ σ. Fun f ss ⋅ σ = Fun f ts"
  using assms subst_merge[of ss "σ"]
  apply auto apply (rule_tac x = σ' in exI)
  apply (intro nth_equalityI) apply auto
  by (metis term_subst_eq)

lemma bless_eq_to_instance:
  assumes "s⊥ ≤b t⊥" and "linear_term s"
  shows "∃ σ. s ⋅ σ = t" using assms
proof (induct s arbitrary: t)
  case (Fun f ts)
  from Fun(2) obtain us where [simp]: "t = Fun f us" "length ts = length us" by (cases t) auto 
  have "i < length ts ⟹ ∃σ. ts ! i ⋅ σ = us ! i" for i
    using Fun(2, 3) Fun(1)[OF nth_mem, of i "us ! i" for i]
    by (auto elim: bless_eq.cases)
  then show ?case using Ex_list_of_length_P[of "length ts" "λ σ i. ts ! i ⋅ σ = us ! i"]
    using linear_term_comb_subst[OF Fun(3)] by auto
qed auto

lemma instance_to_bless_eq:
  assumes "s ⋅ σ = t"
  shows "s⊥ ≤b t⊥" using assms
proof (induct s arbitrary: t)
  case (Fun f ts) then show ?case
    by (cases t) auto
qed auto

end
>

Theory Saturation

theory Saturation
  imports Main
begin

subsection ‹Set operation closure for idempotent, associative, and commutative functions›

lemma inv_to_set:
  "(∀ i < length ss. ss ! i ∈ S) ⟷ set ss ⊆ S"
  by (induct ss) (auto simp: nth_Cons split: nat.splits)

lemma ac_comp_fun_commute:
  assumes "⋀ x y. f x y = f y x" and "⋀ x y z. f x (f y z) = f (f x y) z"
  shows "comp_fun_commute f" using assms unfolding comp_fun_commute_def
  by (auto simp: comp_def) fastforce

lemma (in comp_fun_commute) fold_list_swap:
  "fold f xs (fold f ys y) = fold f ys (fold f xs y)"
  by (metis comp_fun_commute fold_commute fold_commute_apply)

lemma (in comp_fun_commute) foldr_list_swap:
  "foldr f xs (foldr f ys y) = foldr f ys (foldr f xs y)"
  by (simp add: fold_list_swap foldr_conv_fold)

lemma (in comp_fun_commute) foldr_to_fold:
  "foldr f xs = fold f xs"
  using comp_fun_commute foldr_fold[of _ f] 
  by (auto simp: comp_def)

lemma (in comp_fun_commute) fold_commute_f:
  "f x (foldr f xs y) = foldr f xs (f x y)"
  using comp_fun_commute unfolding foldr_to_fold
  by (auto simp: comp_def intro: fold_commute_apply)

lemma closure_sound:
  assumes cl: "⋀ s t. s ∈ S ⟹ t ∈ S ⟹ f s t ∈ S"
    and com: "⋀ x y. f x y = f y x" and ass: "⋀ x y z. f x (f y z) = f (f x y) z"
    and fin: "set ss ⊆ S" "ss ≠ []"
  shows "fold f (tl ss) (hd ss) ∈ S" using assms(4-)
proof (induct ss)
  case (Cons s ss) note IS = this show ?case
  proof (cases ss)
    case Nil
    then show ?thesis using IS by auto
  next
    case (Cons t ts) show ?thesis
      using IS assms(1) ac_comp_fun_commute[of f, OF com ass] unfolding Cons
      by (auto simp flip: comp_fun_commute.foldr_to_fold) (metis com comp_fun_commute.fold_commute_f)
  qed
qed auto

(* Writing a fold that does not take a base element may simplify the proves *)
locale set_closure_oprator =
  fixes f
  assumes com [ac_simps]: "⋀ x y. f x y = f y x"
    and ass [ac_simps]: "⋀ x y z. f x (f y z) = f (f x y) z"
    and idem: "⋀ x. f x x = x"

sublocale set_closure_oprator ⊆ comp_fun_idem
  using set_closure_oprator_axioms ac_comp_fun_commute
  by (auto simp: comp_fun_idem_def comp_fun_idem_axioms_def comp_def set_closure_oprator_def)

context set_closure_oprator
begin

inductive_set closure for S where
  base [simp]: "s ∈ S ⟹ s ∈ closure S"
| step [intro]: "s ∈ closure S ⟹ t ∈ closure S ⟹ f s t ∈ closure S"

lemma closure_idem [simp]:
  "closure (closure S) = closure S" (is "?LS = ?RS")
proof -
  {fix s assume "s ∈ ?LS" then have "s ∈ ?RS" by induct auto}
  moreover
  {fix s assume "s ∈ ?RS" then have "s ∈ ?LS" by induct auto}
  ultimately show ?thesis by blast
qed

lemma fold_dist:
  assumes "xs ≠ []"
  shows "f (fold f (tl xs) (hd xs)) t = fold f xs t" using assms
proof (induct xs)
  case (Cons a xs)
  show ?case using Cons com ass fold_commute_f
    by (auto simp: comp_def foldr_to_fold)
qed auto

lemma closure_to_cons_list:
  assumes "s ∈ closure S"
  shows "∃ ss ≠ []. fold f (tl ss) (hd ss) = s ∧ (∀ i < length ss. ss ! i ∈ S)" using assms
proof (induct)
  case (base s) then show ?case by (auto intro: exI[of _ "[s]"])
next
  case (step s t)
  then obtain ss ts where
    s: "fold f (tl ss) (hd ss) = s" and inv_s: "ss ≠ []" "∀ i < length ss. ss ! i ∈ S" and
    t: "fold f (tl ts) (hd ts) = t" and inv_t: "ts ≠ []" "∀ i < length ts. ts ! i ∈ S"
    by auto
  then show ?case
    by (auto simp: fold_dist nth_append intro!: exI[of _ "ss @ ts"]) (metis com fold_dist)
qed

lemma sound_fold:
  assumes "set ss ⊆ closure S" and "ss ≠ []"
  shows "fold f (tl ss) (hd ss) ∈ closure S" using assms
  using closure_sound[of "closure S" f] assms step
  by (auto simp add: com fun_left_comm)

lemma closure_empty [simp]: "closure {} = {}"
  using closure_to_cons_list by auto

lemma closure_mono:
  "S ⊆ T ⟹ closure S ⊆ closure T"
proof
  fix s assume ass: "s ∈ closure S"
  then show "S ⊆ T ⟹ s ∈ closure T"
    by (induct) (auto simp: closure_to_cons_list)
qed

lemma closure_insert:
  "closure (insert x S) = {x} ∪ closure S ∪ {f x s | s. s ∈ closure S}"
proof -
  {fix t assume ass: "t ∈ closure (insert x S)" "t ≠ x" "t ∉ closure S"
    from closure_to_cons_list[OF ass(1)] obtain ss where
      t: "fold f (tl ss) (hd ss) = t" and inv_t: "ss ≠ []" "∀ i < length ss. ss ! i ∈ insert x S"
      by auto
    then have mem: "x ∈ set ss" using ass(3) sound_fold[of ss] in_set_conv_nth
      by (force simp add: inv_to_set)
    have "∃ s. t = f x s ∧ s ∈ closure S"
    proof (cases "set ss = {x}")
      case True then show ?thesis using ass(2) t
        by (metis com finite.emptyI fold_dist fold_empty fold_insert_idem fold_set_fold idem inv_t(1))
    next
      case False
      from False inv_t(1) mem obtain ts where split: "insert x (set ts) = set ss" "x ∉ set ts" "ts ≠ []"
        by auto (metis False List.finite_set Set.set_insert empty_set finite_insert finite_list)
      then have "∀ i < length ts. ts ! i ∈ S" using inv_t(2) split unfolding inv_to_set by auto 
      moreover have "t = f x (Finite_Set.fold f (hd ts) (set (tl ts)))"
        using split t inv_t(1)
        by (metis List.finite_set com fold_dist fold_insert_idem2 fold_set_fold fun_left_idem idem)   
      ultimately show ?thesis using sound_fold[OF _ split(3)] 
        by (auto simp: foldr_to_fold fold_set_fold inv_to_set) force
    qed}
  then show ?thesis
    by (auto simp: fold_set_fold in_mono[OF closure_mono[OF subset_insertI[of S x]]])
qed

lemma finite_S_finite_closure [intro]:
  "finite S ⟹ finite (closure S)"
  by (induct rule: finite.induct) (auto simp: closure_insert)

end

locale semilattice_closure_operator =
  cl: set_closure_oprator f for f :: "'a ⇒ 'a ⇒ 'a" +
fixes less_eq e
assumes neut_fun [simp]:"⋀ x. f e x = x"
  and neut_less [simp]: "⋀ x. less_eq e x"
  and sup_l: "⋀ x y. less_eq x (f x y)"
  and sup_r: "⋀ x y. less_eq y (f x y)"
  and upper_bound: "⋀ x y z. less_eq x z ⟹ less_eq y z ⟹ less_eq (f x y) z"
  and trans: "⋀ x y z. less_eq x y ⟹ less_eq y z ⟹ less_eq x z"
  and anti_sym: "⋀ x y. less_eq x y ⟹ less_eq y x ⟹ x = y"
begin

lemma unique_neut_elem [simp]:
  "f x y = e ⟷ x = e ∧ y = e"
  using neut_fun cl.fun_left_idem
  by (metis cl.com)

abbreviation "closure S ≡ cl.closure S"


lemma closure_to_cons_listE:
  assumes "s ∈ closure S"
  obtains ss where "ss ≠ []" "fold f ss e = s" "set ss ⊆ S"
  using cl.closure_to_cons_list[OF assms] cl.fold_dist
  by (auto simp: inv_to_set) (metis cl.com neut_fun)

lemma sound_fold:
  assumes "set ss ⊆ closure S" "ss ≠ []"
  shows "fold f ss e ∈ closure S"
  using cl.sound_fold[OF assms] cl.fold_dist[OF assms(2)]
  by (metis cl.com neut_fun)

abbreviation "supremum S ≡ Finite_Set.fold f e S"
definition "smaller_subset x S ≡ {y. less_eq y x ∧ y ∈ S}"

lemma smaller_subset_empty [simp]:
  "smaller_subset x {} = {}"
  by (auto simp: smaller_subset_def)

lemma finite_smaller_subset [simp, intro]:
  "finite S ⟹ finite (smaller_subset x S)"
  by (auto simp: smaller_subset_def)

lemma smaller_subset_mono:
  "smaller_subset x S ⊆ S"
  by (auto simp: smaller_subset_def)

lemma sound_set_fold:
  assumes "set ss ⊆ closure S" and "ss ≠ []"
  shows "supremum (set ss) ∈ closure S"
  using sound_fold[OF assms]
  by (auto simp: cl.fold_set_fold)

lemma supremum_neutral [simp]:
  assumes "finite S" and "supremum S = e"
  shows "S ⊆ {e}" using assms
  by (induct) auto

lemma supremum_in_closure:
  assumes "finite S" and "R ⊆ closure S" and "R ≠ {}"
  shows "supremum R ∈ closure S"
proof -
  obtain L where [simp]: "R = set L"
    using cl.finite_S_finite_closure[OF assms(1)] assms(2) finite_list
    by (metis infinite_super)
  then show ?thesis using sound_set_fold[of L S] assms
    by (cases L) auto
qed

lemma supremum_sound:
  assumes "finite S"
  shows "⋀ t. t ∈ S ⟹ less_eq t (supremum S)"
  using assms sup_l sup_r trans
  by induct (auto, blast)

lemma supremum_sound_list:
  "∀ i < length ss. less_eq (ss ! i) (fold f ss e)"
  unfolding cl.fold_set_fold[symmetric]
  using supremum_sound[of "set ss"]
  by auto

lemma smaller_subset_insert [simp]:
  "less_eq y x ⟹ smaller_subset x (insert y S) = insert y (smaller_subset x S)"
  "¬ less_eq y x ⟹ smaller_subset x (insert y S) = smaller_subset x S"
  by (auto simp: smaller_subset_def)

lemma supremum_smaller_subset:
  assumes "finite S"
  shows "less_eq (supremum (smaller_subset x S)) x" using assms
proof (induct)
  case (insert y F) then show ?case
    by (cases "less_eq y x") (auto simp: upper_bound)
qed simp

lemma pre_subset_eq_pos_subset [simp]:
  shows "smaller_subset x (closure S) = closure (smaller_subset x S)" (is "?LS = ?RS")
proof -
  {fix s assume "s ∈ ?RS" then have "s ∈ ?LS"
      using upper_bound by induct (auto simp: smaller_subset_def)}
  moreover
  {fix s assume ass: "s ∈ ?LS"
    then have "s ∈ closure S" using smaller_subset_mono by auto
    then obtain ss where wit: "ss ≠ [] ∧ fold f ss e = s ∧ (set ss ⊆ S)"
      using closure_to_cons_listE by blast
    then have "∀ i < length ss. less_eq (ss ! i) x"
      using supremum_sound[of "set ss"] supremum_smaller_subset[of "set ss" x]
      unfolding cl.fold_set_fold[symmetric]
      by auto (metis ass local.trans mem_Collect_eq nth_mem smaller_subset_def) 
    then have "s ∈ ?RS" using wit sound_fold[of ss]
      by (auto simp: smaller_subset_def)
        (metis (mono_tags, lifting) cl.closure.base inv_to_set mem_Collect_eq)}
  ultimately show ?thesis by blast
qed


lemma supremum_in_smaller_closure:
  assumes "finite S"
  shows "supremum (smaller_subset x S) ∈ {e} ∪ (closure S)"
  using supremum_in_closure[OF assms, of "smaller_subset x S"]
  by (metis UnI1 UnI2 cl.closure.base fold_empty singletonI smaller_subset_mono subset_iff)


lemma supremum_subset_less_eq:
  assumes "finite S" and "R ⊆ S"
  shows "less_eq (supremum R) (supremum S)" using assms
proof (induct arbitrary: R)
  case (insert x F)
  from insert(1, 2, 4) insert(3)[of "R - {x}"]
  have "less_eq (supremum (R - {x})) (f x (supremum F))"
    by (metis Diff_subset_conv insert_is_Un local.trans sup_r)
  then show ?case using insert(1, 2, 4)
    by auto (metis Diff_empty Diff_insert0 cl.fold_rec finite.insertI finite_subset sup_l upper_bound)
qed (auto)


lemma supremum_smaller_closure [simp]:
  assumes "finite S"
  shows "supremum (smaller_subset x (closure S)) = supremum (smaller_subset x S)"
proof (cases "smaller_subset x S = {}")
  case [simp]: True show ?thesis by auto
next
  case False
  have "smaller_subset x S ⊆ smaller_subset x (closure S)"
    unfolding pre_subset_eq_pos_subset by auto
  then have l: "less_eq (supremum (smaller_subset x S)) (supremum (smaller_subset x (closure S)))"
    using assms unfolding pre_subset_eq_pos_subset
    by (intro supremum_subset_less_eq) auto
  from False have "supremum (closure (smaller_subset x S)) ∈ closure S"
    using assms cl.closure_mono[OF smaller_subset_mono]
    using ‹smaller_subset x S ⊆ smaller_subset x (closure S)›
    by (auto simp add: assms intro!: supremum_in_closure)
  from closure_to_cons_listE[OF this] obtain ss where
    dec : "supremum (smaller_subset x (closure S)) = Finite_Set.fold f e (set ss)"
    and inv: "ss ≠ []" "set ss ⊆ S"
    by (auto simp: cl.fold_set_fold) force
  then have "set ss ⊆ smaller_subset x S"
    using supremum_sound[OF assms]
    using supremum_smaller_subset[OF assms]
    by (auto simp: smaller_subset_def)
      (metis List.finite_set assms cl.finite_S_finite_closure dec trans supremum_smaller_subset supremum_sound)
  then have "less_eq (supremum (smaller_subset x (closure S))) (supremum (smaller_subset x S))"
    using inv assms unfolding dec
    by (intro supremum_subset_less_eq) auto 
  then show ?thesis using l anti_sym
    by auto  
qed

end

fun lift_f_total where
  "lift_f_total P f None _ = None"
| "lift_f_total P f _ None = None"
| "lift_f_total P f (Some s) (Some t) = (if P s t then Some (f s t) else None)"

fun lift_less_eq_total where
  "lift_less_eq_total f _ None = True"
| "lift_less_eq_total f None _ = False"
| "lift_less_eq_total f (Some s) (Some t) = (f s t)"


locale set_closure_partial_oprator =
  fixes P f
  assumes refl: "⋀ x. P x x"
    and sym: "⋀ x y. P x y ⟹ P y x"
    and dist: "⋀ x y z. P y z ⟹ P x (f y z) ⟹ P x y"
    and assP: "⋀ x y z. P x (f y z) ⟹ P y z ⟹ P (f x y) z"
    and com [ac_simps]: "⋀ x y. P x y ⟹ f x y = f y x"
    and ass [ac_simps]: "⋀ x y z. P x y ⟹ P y z ⟹ f x (f y z) = f (f x y) z"
    and idem: "⋀ x. f x x = x"
begin

lemma lift_f_total_com:
  "lift_f_total P f x y = lift_f_total P f y x"
  using com by (cases x; cases y) (auto simp: sym)

lemma lift_f_total_ass:
  "lift_f_total P f x (lift_f_total P f y z) = lift_f_total P f (lift_f_total P f x y) z"
proof (cases x)
  case [simp]: (Some s) show ?thesis
  proof (cases y)
    case [simp]: (Some t) show ?thesis
    proof (cases z)
      case [simp]: (Some u) show ?thesis
        by (auto simp add: ass dist[of t u s])
          (metis com dist assP sym)+
    qed auto
  qed auto
qed auto

lemma lift_f_total_idem:
  "lift_f_total P f x x = x"
  by (cases x) (auto simp: idem refl)

lemma lift_f_totalE[elim]:
  assumes "lift_f_total P f s u = Some t"
  obtains v w where "s = Some v" "u = Some w"
  using assms by (cases s; cases u) auto

lemma lift_set_closure_oprator:
  "set_closure_oprator (lift_f_total P f)"
  using lift_f_total_com lift_f_total_ass lift_f_total_idem by unfold_locales blast+

end

sublocale set_closure_partial_oprator ⊆ lift_fun: set_closure_oprator "lift_f_total P f"
  by (simp add: lift_set_closure_oprator)


context set_closure_partial_oprator begin

abbreviation "lift_closure S ≡ lift_fun.closure (Some ` S)"

inductive_set pred_closure for S where
  base [simp]: "s ∈ S ⟹ s ∈ pred_closure S"
| step [intro]: "s ∈ pred_closure S ⟹ t ∈ pred_closure S ⟹ P s t ⟹ f s t ∈ pred_closure S"

lemma pred_closure_to_some_lift_closure:
  assumes "s ∈ pred_closure S"
  shows "Some s ∈ lift_closure S" using assms
proof (induct)
  case (step s t)
  then have "lift_f_total P f (Some s) (Some t) ∈ lift_closure S"
    by (intro lift_fun.closure.step) auto
  then show ?case using step(5)
    by (auto split: if_splits)
qed auto

lemma some_lift_closure_pred_closure:
  fixes t defines "s ≡ Some t"
  assumes "Some t ∈ lift_closure S"
  shows "t ∈ pred_closure S" using assms(2)
  unfolding assms(1)[symmetric] using assms(1)
proof (induct arbitrary: t)
  case (step s u)
  from step(5) obtain v w where [simp]: "s = Some v" "u = Some w" by auto
  show ?case using step by (auto split: if_splits)
qed auto

lemma pred_closure_lift_closure:
  "pred_closure S = the ` (lift_closure S - {None})" (is "?LS = ?RS")
proof
  {fix s assume "s ∈ ?LS"
    from pred_closure_to_some_lift_closure[OF this] have "s ∈ ?RS"
      by (metis DiffI empty_iff image_iff insertE option.distinct(1) option.sel)}
  then show "?LS ⊆ ?RS" by blast
next 
  {fix s assume ass: "s ∈ ?RS"
    then have "Some s ∈ lift_closure S"
      using option.collapse by fastforce
    from some_lift_closure_pred_closure[OF this] have "s ∈ ?LS"
      using option.collapse by auto}
  then show "?RS ⊆ ?LS" by blast
qed

lemma finite_S_finite_closure [simp, intro]:
  "finite S ⟹ finite (pred_closure S)"
  using finite_subset[of "Some ` pred_closure S" "lift_closure S"]
  using pred_closure_to_some_lift_closure lift_fun.finite_S_finite_closure[of "Some ` S"]
  by (auto simp add: pred_closure_lift_closure set_closure_partial_oprator_axioms) 

lemma closure_mono:
  assumes "S ⊆ T"
  shows "pred_closure S ⊆ pred_closure T"
proof -
  have "Some ` S ⊆ Some ` T" using assms by auto
  from lift_fun.closure_mono[OF this] show ?thesis
    using pred_closure_to_some_lift_closure some_lift_closure_pred_closure set_closure_partial_oprator_axioms
    by fastforce
qed

lemma pred_closure_empty [simp]:
  "pred_closure {} = {}"
  using pred_closure_lift_closure by fastforce
end

locale semilattice_closure_partial_operator =
  cl: set_closure_partial_oprator P f for P and f :: "'a ⇒ 'a ⇒ 'a" +
fixes less_eq e
assumes neut_elm :"⋀ x. f e x = x" 
  and neut_pred: "⋀ x. P e x"
  and neut_less: "⋀ x. less_eq e x" 
  and pred_less: "⋀ x y z. less_eq x y ⟹ less_eq z y ⟹ P x z"
  and sup_l: "⋀ x y. P x y ⟹ less_eq x (f x y)"
  and sup_r: "⋀ x y. P x y ⟹ less_eq y (f x y)"
  and upper_bound: "⋀ x y z. less_eq x z ⟹ less_eq y z ⟹ less_eq (f x y) z"
  and trans: "⋀ x y z. less_eq x y ⟹ less_eq y z ⟹ less_eq x z"
  and anti_sym: "⋀ x y. less_eq x y ⟹ less_eq y x ⟹ x = y"
begin

abbreviation "lifted_less_eq ≡ lift_less_eq_total less_eq"
abbreviation "lifted_fun ≡ lift_f_total P f"

lemma lift_less_eq_None [simp]:
  "lifted_less_eq None y ⟷ y = None"
  by (cases y) auto

lemma lift_less_eq_neut_elm [simp]:
  "lifted_fun (Some e) s = s"
  using neut_elm neut_pred by (cases s) auto

lemma lift_less_eq_neut_less [simp]:
  "lifted_less_eq (Some e) s ⟷ True"
  using neut_less by (cases s) auto

lemma lift_less_eq_sup_l [simp]:
  "lifted_less_eq x (lifted_fun x y) ⟷ True"
  using sup_l by (cases x; cases y) auto

lemma lift_less_eq_sup_r [simp]:
  "lifted_less_eq y (lifted_fun x y) ⟷ True"
  using sup_r by (cases x; cases y) auto

lemma lifted_less_eq_trans [trans]:
  "lifted_less_eq x y ⟹ lifted_less_eq y z ⟹ lifted_less_eq x z"
  using trans by (auto elim!: lift_less_eq_total.elims)

lemma lifted_less_eq_anti_sym [trans]:
  "lifted_less_eq x y ⟹ lifted_less_eq y x ⟹ x = y"
  using anti_sym by (auto elim!: lift_less_eq_total.elims)

lemma lifted_less_eq_upper:
  "lifted_less_eq x z ⟹ lifted_less_eq y z ⟹ lifted_less_eq (lifted_fun x y) z"
  using upper_bound pred_less by (auto elim!: lift_less_eq_total.elims)

lemma semilattice_closure_operator_axioms:
  "semilattice_closure_operator_axioms (lift_f_total P f) (lift_less_eq_total less_eq) (Some e)"
  using lifted_less_eq_upper lifted_less_eq_trans lifted_less_eq_anti_sym
  by unfold_locales (auto elim!: lift_f_total.cases)

end

sublocale semilattice_closure_partial_operator ⊆ lift_ord: semilattice_closure_operator "lift_f_total P f" "lift_less_eq_total less_eq" "Some e"
  by (simp add: cl.lift_set_closure_oprator semilattice_closure_operator.intro semilattice_closure_operator_axioms)


context semilattice_closure_partial_operator
begin

abbreviation "supremum ≡ lift_ord.supremum"
abbreviation "smaller_subset ≡ lift_ord.smaller_subset"


lemma supremum_impl:
  assumes "supremum (set (map Some ss)) = Some t"
  shows "foldr f ss e = t" using assms
proof (induct ss arbitrary: t)
  case (Cons a ss)
  then show ?case
    by auto (metis cl.lift_f_totalE lift_f_total.simps(3) option.distinct(1) option.sel) 
qed auto

lemma supremum_smaller_exists_unique:
  assumes "finite S"
  shows "∃! p. supremum (smaller_subset (Some t) (Some ` S)) = Some p" using assms
proof (induct)
  case (insert x F) show ?case
  proof (cases "lifted_less_eq (Some x) (Some t)")
    case True
    obtain p where wit: "supremum (smaller_subset (Some t) (Some ` F)) = Some p"
      using insert by auto
    then have pred: "less_eq p t" "less_eq x t" using True insert(1)
      using lift_ord.supremum_smaller_subset
      by auto (metis finite_imageI lift_less_eq_total.simps(3)) 
    show ?thesis using insert pred wit pred_less
      by auto
  next
    case False then show ?thesis
      using insert by auto 
  qed
qed auto

lemma supremum_neut_or_in_closure:
  assumes "finite S"
  shows "the (supremum (smaller_subset (Some t) (Some ` S))) ∈ {e} ∪ cl.pred_closure S"
  using supremum_smaller_exists_unique[OF assms]
  using lift_ord.supremum_in_smaller_closure[of "Some ` S" "Some t"] assms
  by auto (metis cl.some_lift_closure_pred_closure option.sel)

end

(* At the moment we remove duplicates in each iteration,
   use data structure that can deal better with duplication i.e red black trees *)
fun closure_impl where
  "closure_impl f [] = []"
| "closure_impl f (x # S) = (let cS = closure_impl f S in remdups (x # cS @ map (f x) cS))"

lemma (in set_closure_oprator) closure_impl [simp]:
  "set (closure_impl f S) = closure (set S)"
  by (induct S, auto simp: closure_insert Let_def)

lemma (in set_closure_partial_oprator) closure_impl [simp]:
  "set (map the (removeAll None (closure_impl (lift_f_total P f) (map Some S)))) = pred_closure (set S)"
  using lift_set_closure_oprator set_closure_oprator.closure_impl pred_closure_lift_closure
  by auto

end

Theory Rewriting

section ‹Rewriting›

theory Rewriting
  imports Regular_Tree_Relations.Term_Context
    Regular_Tree_Relations.Ground_Terms
    Utils
begin

subsection ‹Type definitions and rewrite relation definitions›
type_synonym 'f sig = "('f × nat) set"
type_synonym ('f, 'v) rule = "('f, 'v) term × ('f, 'v) term"
type_synonym ('f, 'v) trs  = "('f, 'v) rule set"


definition "sig_step ℱ ℛ = {(s, t). funas_term s ⊆ ℱ ∧ funas_term t ⊆ ℱ ∧ (s, t) ∈ ℛ}"

inductive_set rstep :: "_ ⇒ ('f, 'v) term rel" for R :: "('f, 'v) trs"
  where
    rstep: "⋀C σ l r. (l, r) ∈ R ⟹ s = C⟨l ⋅ σ⟩ ⟹ t = C⟨r ⋅ σ⟩ ⟹ (s, t) ∈ rstep R"

definition rstep_r_p_s :: "('f, 'v) trs ⇒ ('f, 'v) rule ⇒ pos ⇒ ('f, 'v) subst ⇒ ('f, 'v) trs" where
  "rstep_r_p_s R r p σ = {(s, t). p ∈ poss s ∧ p ∈ poss t ∧ r ∈ R ∧ ctxt_at_pos s p = ctxt_at_pos t p ∧
     s[p ← (fst r ⋅ σ)] = s ∧ t[p ← (snd r ⋅ σ)] = t}"

text ‹Rewriting steps below the root position.›
definition nrrstep :: "('f, 'v) trs ⇒ ('f, 'v) trs" where
  "nrrstep R = {(s,t). ∃r i ps σ. (s,t) ∈ rstep_r_p_s R r (i#ps) σ}"

text ‹Rewriting step at the root position.›
definition rrstep :: "('f, 'v) trs ⇒ ('f, 'v) trs" where
  "rrstep R = {(s,t). ∃r σ. (s,t) ∈ rstep_r_p_s R r [] σ}"

text ‹the parallel rewrite relation›
inductive_set par_rstep :: "('f,'v)trs ⇒ ('f,'v)trs" for R :: "('f,'v)trs"
  where root_step[intro]: "(s,t) ∈ R ⟹ (s ⋅ σ,t ⋅ σ) ∈ par_rstep R"
     |  par_step_fun[intro]: "⟦⋀ i. i < length ts ⟹ (ss ! i,ts ! i) ∈ par_rstep R⟧ ⟹ length ss = length ts
             ⟹ (Fun f ss, Fun f ts) ∈ par_rstep R"
     |  par_step_var[intro]: "(Var x, Var x) ∈ par_rstep R"


subsection ‹Ground variants connecting to FORT›

definition grrstep :: "('f, 'v) trs ⇒ 'f gterm rel" where
  "grrstep ℛ = inv_image (rrstep ℛ) term_of_gterm"

definition gnrrstep :: "('f, 'v) trs ⇒ 'f gterm rel" where
  "gnrrstep ℛ = inv_image (nrrstep ℛ) term_of_gterm"

definition grstep :: "('f, 'v) trs ⇒ 'f gterm rel" where
  "grstep ℛ = inv_image (rstep ℛ) term_of_gterm"

definition gpar_rstep :: "('f, 'v) trs ⇒ 'f gterm rel" where
  "gpar_rstep ℛ = inv_image (par_rstep ℛ) term_of_gterm"


text ‹
  An alternative induction scheme that treats the rule-case, the
  substition-case, and the context-case separately.
›
lemma rstep_induct [consumes 1, case_names rule subst ctxt]:
  assumes "(s, t) ∈ rstep R"
    and rule: "⋀l r. (l, r) ∈ R ⟹ P l r"
    and subst: "⋀s t σ. P s t ⟹ P (s ⋅ σ) (t ⋅ σ)"
    and ctxt: "⋀s t C. P s t ⟹ P (C⟨s⟩) (C⟨t⟩)"
  shows "P s t"
  using assms by (induct) auto


lemmas rstepI = rstep.intros [intro]

lemmas rstepE = rstep.cases [elim]

lemma rstep_ctxt [intro]: "(s, t) ∈ rstep R ⟹ (C⟨s⟩, C⟨t⟩) ∈ rstep R"
  by (force simp flip: ctxt_ctxt_compose)

lemma rstep_rule [intro]: "(l, r) ∈ R ⟹ (l, r) ∈ rstep R"
  using rstep.rstep [where C = □ and σ = Var and R = R] by simp

lemma rstep_subst [intro]: "(s, t) ∈ rstep R ⟹ (s ⋅ σ, t ⋅ σ) ∈ rstep R"
  by (force simp flip: subst_subst_compose)

lemma nrrstep_def':
  "nrrstep R = {(s, t). ∃l r C σ. (l, r) ∈ R ∧ C ≠ □ ∧ s = C⟨l⋅σ⟩ ∧ t = C⟨r⋅σ⟩}" (is "?Ls = ?Rs")
proof
  show "?Ls ⊆ ?Rs"
  proof (rule subrelI)
    fix s t assume "(s, t) ∈ ?Ls"
    then obtain l r i ps σ where step: "(s, t) ∈ rstep_r_p_s R (l, r) (i # ps) σ"
          unfolding nrrstep_def by best
    let ?C = "ctxt_at_pos s (i # ps)"
    from step have"i # ps ∈ poss s" and "(l, r) ∈ R" and "s = ?C⟨l⋅σ⟩" and "t = ?C⟨r⋅σ⟩"
      unfolding rstep_r_p_s_def Let_def by (auto simp flip: replace_term_at_replace_at_conv)
    moreover from ‹i # ps ∈ poss s› have "?C ≠ □" by (induct s) auto
    ultimately show "(s, t) ∈ ?Rs" by auto
  qed
next
  show "?Rs ⊆ ?Ls"
  proof (rule subrelI)
    fix s t assume "(s, t) ∈ ?Rs"
    then obtain l r C σ where in_R: "(l, r) ∈ R" and "C ≠ □"
      and s: "s = C⟨l⋅σ⟩" and t: "t = C⟨r⋅σ⟩" by auto
    from ‹C ≠ □› obtain i p where ip: "hole_pos C = i # p" by (induct C) auto
    have "i # p ∈ poss s" unfolding s ip[symmetric] by simp
    then have C: "C = ctxt_at_pos s (i # p) "
      unfolding s ip[symmetric] by simp
    from ‹i # p ∈ poss s› in_R s t have "(s, t) ∈ rstep_r_p_s R (l, r) (i # p) σ"
      unfolding rstep_r_p_s_def C[symmetric] ip[symmetric] by simp
    then show "(s, t) ∈ nrrstep R" unfolding nrrstep_def by best
  qed
qed

lemma rrstep_def': "rrstep R = {(s, t). ∃l r σ. (l, r) ∈ R ∧ s = l⋅σ ∧ t = r⋅σ}"
  by (auto simp: rrstep_def rstep_r_p_s_def)


lemma rstep_imp_C_s_r:
  assumes "(s,t) ∈ rstep R"
  shows "∃C σ l r. (l,r) ∈ R ∧ s = C⟨l⋅σ⟩ ∧ t = C⟨r⋅σ⟩" using assms
  by (induct) auto

lemma rhs_wf:
  assumes R: "(l, r) ∈ R" and "funas_trs R ⊆ F"
  shows "funas_term r ⊆ F"
  using assms by (force simp: funas_trs_def)

abbreviation "linear_sys ℛ ≡ (∀ (l, r) ∈ ℛ. linear_term l ∧ linear_term r)"
abbreviation "const_subt c ≡ λ x. Fun c []"



end

Theory LV_to_GTT

section ‹Primitive constructions›

theory LV_to_GTT
  imports Regular_Tree_Relations.Pair_Automaton   
    Bot_Terms 
    Rewriting
begin

subsection ‹Recognizing subterms of linear terms›
(* Pattern recognizer automaton *)
abbreviation ffunas_terms where
  "ffunas_terms R ≡ |⋃| (ffunas_term |`| R)"

definition "states R ≡ {t⊥ | s t. s ∈ R ∧ s ⊵ t}"

lemma states_conv:
  "states R = term_to_bot_term ` (⋃ s ∈ R. subterms s)"
  unfolding states_def set_all_subteq_subterms
  by auto

lemma finite_states:
  assumes "finite R" shows "finite (states R)"
proof -
  have conv: "states R = term_to_bot_term ` (⋃ s ∈ R. {t | t. s ⊵ t})"
    unfolding states_def by auto
  from assms have "finite (⋃ s ∈ R. {t | t. s ⊵ t})"
    by (intro finite_UN_I2 finite_imageI) (simp add: finite_subterms)+
  then show ?thesis using conv by auto
qed

lemma root_bot_diff:
  "root_bot ` (R - {Bot}) = (root_bot ` R) - {None}"
  using root_bot.elims by auto

lemma root_bot_states_root_subterms:
  "the ` (root_bot ` (states R - {Bot})) = the ` (root ` (⋃ s ∈ R. subterms s) - {None})"
  unfolding states_conv root_bot_diff
  unfolding image_comp
  by simp

context
includes fset.lifting
begin

lift_definition fstates :: "('f, 'v) term fset ⇒ 'f bot_term fset" is states
  by (simp add: finite_states)

lift_definition fsubterms :: "('f, 'v) term ⇒ ('f, 'v) term fset" is subterms
  by (simp add: finite_subterms_fun)

lemmas fsubterms [code] = subterms.simps[Transfer.transferred]

lift_definition ffunas_trs :: "(('f, 'v) term × ('f, 'v) term) fset ⇒ ('f × nat) fset" is funas_trs
  by (simp add: finite_funas_trs)

lemma fstates_def':
  "t |∈| fstates R ⟷ (∃ s u. s |∈| R ∧ s ⊵ u ∧ u⊥ = t)"
  by transfer (auto simp: states_def)

lemma fstates_fmemberE [elim!]:
  assumes "t |∈| fstates R"
  obtains s u where "s |∈| R ∧ s ⊵ u ∧ u⊥ = t"
  using assms unfolding fstates_def'
  by blast

lemma fstates_fmemberI [intro]:
  "s |∈| R ⟹ s ⊵ u ⟹ u⊥ |∈| fstates R"
  unfolding fstates_def' by blast

lemmas froot_bot_states_root_subterms = root_bot_states_root_subterms[Transfer.transferred]
lemmas root_fsubsterms_ffunas_term_fset = root_substerms_funas_term_set[Transfer.transferred]


lemma fstates[code]:
  "fstates R = term_to_bot_term |`| ( |⋃| (fsubterms |`| R))"
  by transfer (auto simp: states_conv)

end

definition ta_rule_sig where 
  "ta_rule_sig = (λ r. (r_root r, length (r_lhs_states r)))"

primrec term_to_ta_rule where
 "term_to_ta_rule (BFun f ts) = TA_rule f ts (BFun f ts)"

lemma ta_rule_sig_term_to_ta_rule_root:
  "t ≠ Bot ⟹ ta_rule_sig (term_to_ta_rule t) = the (root_bot t)"
  by (cases t) (auto simp: ta_rule_sig_def)

lemma ta_rule_sig_term_to_ta_rule_root_set:
  assumes "Bot |∉| R"
  shows "ta_rule_sig |`| (term_to_ta_rule |`| R) = the |`| (root_bot |`| R)"
proof -
  {fix x assume "x |∈| R" then have "ta_rule_sig (term_to_ta_rule x) = the (root_bot x)"
      using ta_rule_sig_term_to_ta_rule_root[of x] assms
      by auto}
  then show ?thesis
    by (force simp: fimage_iff)
qed

definition pattern_automaton_rules where
  "pattern_automaton_rules ℱ R =
    (let states = (fstates R) - {|Bot|} in
    term_to_ta_rule |`| states |∪| (λ (f, n). TA_rule f (replicate n Bot) Bot) |`| ℱ)"

lemma pattern_automaton_rules_BotD:
  assumes "TA_rule f ss Bot |∈| pattern_automaton_rules ℱ R"
  shows "TA_rule f ss Bot |∈| (λ (f, n). TA_rule f (replicate n Bot) Bot) |`| ℱ" using assms
  by (auto simp: pattern_automaton_rules_def)
     (metis ta_rule.inject term_to_bot_term.elims term_to_ta_rule.simps)

lemma pattern_automaton_rules_FunD:
  assumes "TA_rule f ss (BFun g ts) |∈| pattern_automaton_rules ℱ R"
  shows "g = f ∧ ts = ss ∧
     TA_rule f ss (BFun g ts) |∈| term_to_ta_rule |`| ((fstates R) - {|Bot|})" using assms
  apply (auto simp: pattern_automaton_rules_def)
  apply (metis bot_term.exhaust ta_rule.inject term_to_ta_rule.simps)
  by (metis (no_types, lifting) ta_rule.inject term_to_bot_term.elims term_to_ta_rule.simps)


definition pattern_automaton where
  "pattern_automaton ℱ R = TA (pattern_automaton_rules ℱ R) {||}"

lemma ta_sig_pattern_automaton [simp]:
  "ta_sig (pattern_automaton ℱ R) = ℱ |∪| ffunas_terms R"
proof -
  let ?r = "ta_rule_sig"
  have *:"Bot |∉| (fstates R) - {|Bot|}" by simp
  have f: "ℱ = ?r |`| ((λ (f, n). TA_rule f (replicate n Bot) Bot) |`| ℱ)"
    by (auto simp: fimage_iff fBex_def ta_rule_sig_def split!: prod.splits)
  moreover have "ffunas_terms R = ?r |`| (term_to_ta_rule |`| ((fstates R) - {|Bot|}))"
    unfolding ta_rule_sig_term_to_ta_rule_root_set[OF *]
    unfolding froot_bot_states_root_subterms root_fsubsterms_ffunas_term_fset
    by simp
  ultimately show ?thesis unfolding pattern_automaton_def ta_sig_def
    unfolding ta_rule_sig_def pattern_automaton_rules_def
      by (auto simp add: Let_def comp_def fimage_funion)
qed

lemma terms_reach_Bot:
  assumes "ffunas_gterm t |⊆| ℱ"
  shows "Bot |∈| ta_der (pattern_automaton ℱ R) (term_of_gterm t)" using assms
proof (induct t)
  case (GFun f ts)
  have [simp]: "s ∈ set ts ⟹ ffunas_gterm s |⊆| ℱ" for s using GFun(2)
    using in_set_idx by fastforce
  from GFun show ?case
    by (auto simp: pattern_automaton_def pattern_automaton_rules_def rev_fimage_eqI
             intro!: exI[of _ "replicate (length ts) Bot"])
qed

lemma pattern_automaton_reach_smaller_term:
  assumes "l |∈| R" "l ⊵ s" "s⊥ ≤b (term_of_gterm t)⊥" "ffunas_gterm t |⊆| ℱ"
  shows "s⊥ |∈| ta_der (pattern_automaton ℱ R) (term_of_gterm t)" using assms(2-)
proof (induct t arbitrary: s)
  case (GFun f ts) show ?case
  proof (cases s)
    case (Var x)
    then show ?thesis using terms_reach_Bot[OF GFun(4)]
      by (auto simp del: ta_der_Fun)
  next
    case [simp]: (Fun g ss)
    let ?ss = "map term_to_bot_term ss"
    have [simp]: "s ∈ set ts ⟹ ffunas_gterm s |⊆| ℱ" for s using GFun(4)
      using in_set_idx by fastforce
    from GFun(3) have s: "g = f" "length ss = length ts" by auto
    from GFun(2) s(2) assms(1) have rule: "TA_rule f ?ss (BFun f ?ss) |∈| pattern_automaton_rules ℱ R"
      by (auto simp: s(1) pattern_automaton_rules_def fimage_iff fBex_def)
    {fix i assume bound: "i < length ts"
      then have sub: "l ⊵ ss ! i" using GFun(2) arg_subteq[OF nth_mem, of i ss f]
        unfolding Fun s(1) using s(2) by (metis subterm.order.trans)
      have "ss ! i⊥ ≤b (term_of_gterm (ts ! i):: ('a, 'c) term)⊥" using GFun(3) bound s(2)
        by (auto simp: s elim!: bless_eq.cases)
      from GFun(1)[OF nth_mem sub this] bound
      have "ss ! i⊥ |∈| ta_der (pattern_automaton ℱ R) (term_of_gterm (ts ! i))"
        by auto}
    then show ?thesis using GFun(2-) s(2) rule
      by (auto simp: s(1) pattern_automaton_def intro!: exI[of _ ?ss] exI[of _ "BFun f ?ss"])
  qed
qed

lemma bot_term_of_gterm_conv:
  "term_of_gterm s⊥ = term_of_gterm s⊥"
  by (induct s) auto

lemma pattern_automaton_ground_instance_reach:
  assumes "l |∈| R" "l ⋅ σ = (term_of_gterm t)" "ffunas_gterm t |⊆| ℱ"
  shows "l⊥ |∈| ta_der (pattern_automaton ℱ R) (term_of_gterm t)"
proof -
  let ?t = "(term_of_gterm t) :: ('a, 'a bot_term) term"
  from instance_to_bless_eq[OF assms(2)] have sm: "l⊥ ≤b ?t⊥"
    using bot_term_of_gterm_conv by metis
  show ?thesis using pattern_automaton_reach_smaller_term[OF assms(1) _ sm] assms(3-)
    by auto
qed

lemma pattern_automaton_reach_smallet_term:
  assumes "l⊥ |∈| ta_der (pattern_automaton ℱ R) t" "ground t"
  shows "l⊥ ≤b t⊥" using assms
proof (induct t arbitrary: l)
  case (Fun f ts) note IH = this show ?case
  proof (cases l)
    case (Fun g ss)
    let ?ss = "map term_to_bot_term ss"
    from IH(2) have rule: "g = f" "length ss = length ts"
      "TA_rule f ?ss (BFun f ?ss) |∈| rules (pattern_automaton ℱ R)"
        by (auto simp: Fun pattern_automaton_def dest: pattern_automaton_rules_FunD)
    {fix i assume "i < length ts" 
      then have "ss ! i⊥ ≤b ts ! i⊥" using IH(2, 3) rule(2)
        by (intro IH(1)) (auto simp: Fun pattern_automaton_def dest: pattern_automaton_rules_FunD)}
    then show ?thesis using rule(2)
      by (auto simp: Fun rule(1))  
  qed auto
qed auto

subsection ‹Recognizing root step relation of LV-TRSs›

definition lv_trs :: "('f, 'v) trs ⇒ bool" where
  "lv_trs R ≡ ∀(l, r) ∈ R. linear_term l ∧ linear_term r ∧ (vars_term l ∩ vars_term r = {})"

lemma subst_unification:
   assumes "vars_term s ∩ vars_term t = {}"
   obtains μ where "s ⋅ σ = s ⋅ μ" "t ⋅ τ = t ⋅ μ"
   using assms
   by (auto intro!: that[of "λx. if x ∈ vars_term s then σ x else τ x"] simp: term_subst_eq_conv)

lemma lv_trs_subst_unification:
  assumes "lv_trs R" "(l, r) ∈ R" "s = l ⋅ σ" "t = r ⋅ τ"
  obtains μ where "s = l ⋅ μ ∧ t = r ⋅ μ"
  using assms subst_unification[of l r σ τ]
  unfolding lv_trs_def
  by (force split!: prod.splits)

definition Relf where
  "Relf R = map_both term_to_bot_term |`| R"

definition root_pair_automaton where
  "root_pair_automaton ℱ R = (pattern_automaton ℱ (fst |`| R),
     pattern_automaton ℱ (snd |`| R))"

definition agtt_grrstep where
  "agtt_grrstep ℛ ℱ = pair_at_to_agtt' (root_pair_automaton ℱ ℛ) (Relf ℛ)"

lemma agtt_grrstep_eps_trancl [simp]:
  "(eps (fst (agtt_grrstep ℛ ℱ)))|+| = eps (fst (agtt_grrstep ℛ ℱ))"
  "(eps (snd (agtt_grrstep ℛ ℱ))) = {||}"
  by (auto simp add: agtt_grrstep_def pair_at_to_agtt'_def
     pair_at_to_agtt_def Let_def root_pair_automaton_def pattern_automaton_def
     fmap_states_ta_def intro!: frelcomp_empty_ftrancl_simp)

lemma root_pair_automaton_grrstep:
  fixes R :: "('f, 'v) rule fset"
  assumes "lv_trs (fset R)" "ffunas_trs R |⊆| ℱ"
  shows "pair_at_lang (root_pair_automaton ℱ R) (Relf R) = Restr (grrstep (fset R)) (𝒯G (fset ℱ))" (is "?Ls = ?Rs")
proof
  let ?t_o_g = "term_of_gterm :: 'f gterm ⇒ ('f, 'v) Term.term"
  have [simp]: "ℱ |∪| |⋃| ((ffunas_term ∘ fst) |`| R) = ℱ"
    "ℱ |∪| |⋃| ((ffunas_term ∘ snd) |`| R) = ℱ" using assms(2)
    by (force simp: less_eq_fset.rep_eq ffunas_trs.rep_eq funas_trs_def ffunas_term.rep_eq fmember.rep_eq ffUnion.rep_eq)+
  {fix s t assume "(s, t) ∈ ?Ls"
    from pair_at_langE[OF this] obtain p q where st: "(q, p) |∈| Relf R"
      "q |∈| gta_der (fst (root_pair_automaton ℱ R)) s" "p |∈| gta_der (snd (root_pair_automaton ℱ R)) t"
      by blast
    from st(1) obtain l r where tm: "q = l⊥" "p = r⊥" "(l, r) |∈| R" unfolding Relf_def
      using assms(1) by (auto simp: fmember.abs_eq)
    have sm: "l⊥ ≤b (?t_o_g s)⊥" "r⊥ ≤b (?t_o_g t)⊥"
      using pattern_automaton_reach_smallet_term[of l ℱ "fst |`| R" "term_of_gterm s"]
      using pattern_automaton_reach_smallet_term[of r ℱ "snd |`| R" "term_of_gterm t"]
      using st(2, 3) tm(3) unfolding tm
      by (auto simp: gta_der_def root_pair_automaton_def) (smt bot_term_of_gterm_conv)+
    have "linear_term l" "linear_term r" using tm(3) assms(1)
      by (auto simp: lv_trs_def fmember.rep_eq)
    then obtain σ τ where "l ⋅ σ = ?t_o_g s" "r ⋅ τ = ?t_o_g t" using sm
      by (auto dest!: bless_eq_to_instance)
    then obtain μ where subst: "l ⋅ μ = ?t_o_g s" "r ⋅ μ = ?t_o_g t"
      using lv_trs_subst_unification[OF assms(1) tm(3)[unfolded fmember.rep_eq], of "?t_o_g s" σ "?t_o_g t" τ]
      by metis
    moreover have "s ∈ 𝒯G (fset ℱ)" "t ∈ 𝒯G (fset ℱ)" using st(2-) assms
      using ta_der_gterm_sig[of q "pattern_automaton ℱ (fst |`| R)" s]
      using ta_der_gterm_sig[of p "pattern_automaton ℱ (snd |`| R)" t]
      by (auto simp: gta_der_def root_pair_automaton_def 𝒯G_equivalent_def less_eq_fset.rep_eq ffunas_gterm.rep_eq)
    ultimately have "(s, t) ∈ ?Rs" using tm(3)
      by (auto simp: grrstep_def rrstep_def' fmember.rep_eq) metis}
  then show "?Ls ⊆ ?Rs" by auto
next
  let ?t_o_g = "term_of_gterm :: 'f gterm ⇒ ('f, 'v) Term.term"
  {fix s t assume "(s, t) ∈ ?Rs"
    then obtain σ l r where st: "(l, r) |∈| R" "l ⋅ σ = ?t_o_g s" "r ⋅ σ = ?t_o_g t" "s ∈ 𝒯G (fset ℱ)" "t ∈ 𝒯G (fset ℱ)"
      by (auto simp: grrstep_def rrstep_def' fmember.rep_eq)
    have funas: "ffunas_gterm s |⊆| ℱ" "ffunas_gterm t |⊆| ℱ" using st(4, 5)
      by (auto simp: 𝒯G_equivalent_def)
         (metis ffunas_gterm.rep_eq notin_fset subsetD)+
    from st(1) have "(l⊥, r⊥) |∈| Relf R" unfolding Relf_def using assms(1)
      by (auto simp: fimage_iff fBex_def)
    then have "(s, t) ∈ ?Ls" using st
      using pattern_automaton_ground_instance_reach[of l "fst |`| R" σ, OF _ _ funas(1)]
      using pattern_automaton_ground_instance_reach[of r "snd |`| R" σ, OF _ _ funas(2)]
      by (auto simp: 𝒯G_equivalent_def fimage_iff fBex_def fmember.abs_eq root_pair_automaton_def gta_der_def pair_at_lang_def)}
  then show "?Rs ⊆ ?Ls" by auto
qed


lemma agtt_grrstep:
  fixes R :: "('f, 'v) rule fset"
  assumes "lv_trs (fset R)" "ffunas_trs R |⊆| ℱ"
  shows "agtt_lang (agtt_grrstep R ℱ) = Restr (grrstep (fset R)) (𝒯G (fset ℱ))"
  using root_pair_automaton_grrstep[OF assms] unfolding pair_at_agtt_cost agtt_grrstep_def
  by simp

(* Results for set as input *)
lemma root_pair_automaton_grrstep_set:
  fixes R :: "('f, 'v) rule set"
  assumes "finite R" "finite ℱ" "lv_trs R" "funas_trs R ⊆ ℱ"
  shows "pair_at_lang (root_pair_automaton (Abs_fset ℱ) (Abs_fset R)) (Relf (Abs_fset R)) = Restr (grrstep R) (𝒯G ℱ)"
proof -
  from assms(1, 2, 4) have "ffunas_trs (Abs_fset R) |⊆| Abs_fset ℱ"
    by (auto simp add: Abs_fset_inverse ffunas_trs.rep_eq fmember.rep_eq subset_eq)
  from root_pair_automaton_grrstep[OF _ this] assms
  show ?thesis
    by (auto simp: Abs_fset_inverse)
qed

lemma agtt_grrstep_set:
  fixes R :: "('f, 'v) rule set"
  assumes "finite R" "finite ℱ" "lv_trs R" "funas_trs R ⊆ ℱ"
  shows "agtt_lang (agtt_grrstep (Abs_fset R) (Abs_fset ℱ)) = Restr (grrstep R) (𝒯G ℱ)"
  using root_pair_automaton_grrstep_set[OF assms] unfolding pair_at_agtt_cost agtt_grrstep_def
  by simp

end
lass="head">

Theory NF

theory NF
  imports
    Saturation
    Bot_Terms
    Regular_Tree_Relations.Tree_Automata
begin

subsection ‹Recognizing normal forms of left linear TRSs›

interpretation lift_total: semilattice_closure_partial_operator "λ x y. (x, y) ∈ mergeP" "(↑)" "λ x y. x ≤b y" Bot
  apply unfold_locales apply (auto simp: merge_refl merge_symmetric merge_terms_assoc merge_terms_idem merge_bot_args_bless_eq_merge)
  using merge_dist apply blast
  using megeP_ass apply blast
  using merge_terms_commutative apply blast
  apply (metis bless_eq_mergeP bless_eq_trans merge_bot_args_bless_eq_merge merge_dist merge_symmetric merge_terms_commutative)
  apply (metis merge_bot_args_bless_eq_merge merge_symmetric merge_terms_commutative)
  using bless_eq_closued_under_supremum bless_eq_trans bless_eq_anti_sym
  by blast+

abbreviation "psubt_lhs_bot R ≡ {t⊥ | s t. s ∈ R ∧ s ⊳ t}"
abbreviation "closure S ≡ lift_total.cl.pred_closure S"

definition states where
  "states R = insert Bot (closure (psubt_lhs_bot R))"

lemma psubt_mono:
  "R ⊆ S ⟹ psubt_lhs_bot R ⊆ psubt_lhs_bot S" by auto

lemma states_mono:
  "R ⊆ S ⟹ states R ⊆ states S"
  unfolding states_def using lift_total.cl.closure_mono[OF psubt_mono[of R S]]
  by auto

lemma finite_lhs_subt [simp, intro]:
  assumes "finite R"
  shows "finite (psubt_lhs_bot R)"
proof -
  have conv: "psubt_lhs_bot R = term_to_bot_term ` {t | s t . s ∈ R ∧ s ⊳ t}" by auto
  from assms have "finite {t | s t . s ∈ R ∧ s ⊳ t}"
    by (simp add: finite_strict_subterms) 
  then show ?thesis using conv by auto
qed

lemma states_ref_closure:
  "states R ⊆ insert Bot (closure (psubt_lhs_bot R))"
  unfolding states_def by auto

lemma finite_R_finite_states [simp, intro]:
  "finite R ⟹ finite (states R)"
  using finite_lhs_subt states_ref_closure
  using lift_total.cl.finite_S_finite_closure finite_subset
  by fastforce

abbreviation "lift_sup_small s S ≡ lift_total.supremum (lift_total.smaller_subset (Some s) (Some ` S))"
abbreviation "bound_max s S ≡ the (lift_sup_small s S)"

lemma bound_max_state_set:
  assumes "finite R"
  shows "bound_max t (psubt_lhs_bot R) ∈ states R"
  using lift_total.supremum_neut_or_in_closure[OF finite_lhs_subt[OF assms], of t]
  unfolding states_def by auto

context
includes fset.lifting
begin
lift_definition fstates :: "('a, 'b) term fset ⇒ 'a bot_term fset" is states
  by simp

lemma bound_max_state_fset:
  "bound_max t (psubt_lhs_bot (fset R)) |∈| fstates R"
  using bound_max_state_set[of "fset R" t]
  using fstates.rep_eq notin_fset by fastforce

end

definition nf_rules where
  "nf_rules R ℱ = {|TA_rule f qs q | f qs q. (f, length qs) |∈| ℱ ∧ fset_of_list qs |⊆| fstates R ∧
      ¬(∃ l |∈| R. l⊥ ≤b BFun f qs) ∧ q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))|}"

lemma nf_rules_fmember:
  "TA_rule f qs q |∈| nf_rules R ℱ ⟷ (f, length qs) |∈| ℱ ∧ fset_of_list qs |⊆| fstates R ∧
    ¬(∃ l |∈| R. l⊥ ≤b BFun f qs) ∧ q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))"
proof -
  let ?subP = "λ n qs. fset_of_list qs |⊆| fstates R ∧ length qs = n"
  let ?sub = "λ n. Collect (?subP n)"
  have *: "finite (?sub n)" for n
    using finite_lists_length_eq[of "fset (fstates R)" n]
    by (simp add: less_eq_fset.rep_eq fset_of_list.rep_eq)
  {fix f n assume mem: "(f, n) ∈ fset ℱ"
    have **: "{f} × (?sub n) = {(f, qs) |qs. ?subP n qs}" by auto
    from mem have "finite {(f, qs) |qs. ?subP n qs}" using *
      using finite_cartesian_product[OF _ *[of n], of "{f}"] unfolding ** by simp}
  then have *: "finite (⋃ (f, n) ∈ fset ℱ . {(f, qs) | qs. ?subP n qs})" by auto
  have **: "(⋃ (f, n) ∈ fset ℱ . {(f, qs) | qs. ?subP n qs}) = {(f, qs) | f qs. (f, length qs) |∈| ℱ ∧ ?subP (length qs) qs}"
    by (auto simp: fmember.rep_eq)
  have *: "finite ({(f, qs) | f qs. (f, length qs) |∈| ℱ ∧ ?subP (length qs) qs} × fset (fstates R))"
    using * unfolding ** by (intro finite_cartesian_product) auto
  have **: "{TA_rule f qs q | f qs q. (f, length qs) |∈| ℱ ∧ fset_of_list qs |⊆| fstates R ∧ q |∈| fstates R} =
    (λ ((f, qs), q). TA_rule f qs q) ` ({(f, qs) | f qs. (f, length qs) |∈| ℱ ∧ ?subP (length qs) qs} × fset (fstates R))"
    by (auto simp: image_def fmember.rep_eq split!: prod.splits) 
  have f: "finite {TA_rule f qs q | f qs q. (f, length qs) |∈| ℱ ∧ fset_of_list qs |⊆| fstates R ∧ q |∈| fstates R}"
    unfolding ** using * by auto
  show ?thesis
    by (auto simp: nf_rules_def bound_max_state_fset intro!: finite_subset[OF _ f])
qed

definition nf_ta where
  "nf_ta R ℱ = TA (nf_rules R ℱ) {||}"

definition nf_reg where
  "nf_reg R ℱ = Reg (fstates R) (nf_ta R ℱ)"

lemma bound_max_sound:
  assumes "finite R"
  shows "bound_max t (psubt_lhs_bot R) ≤b t"
  using assms lift_total.lift_ord.supremum_smaller_subset[of "Some ` psubt_lhs_bot R" "Some t"]
  by auto (metis (no_types, lifting) lift_less_eq_total.elims(2) option.sel option.simps(3))

lemma Bot_in_filter:
  "Bot ∈ Set.filter (λs. s ≤b t) (states R)"
  by (auto simp: Set.filter_def states_def)

lemma bound_max_exists:
  "∃ p. p = bound_max t (psubt_lhs_bot R)"
  by blast

lemma bound_max_unique:
  assumes "p = bound_max t (psubt_lhs_bot R)" and "q = bound_max t (psubt_lhs_bot R)"
  shows "p = q" using assms by force

lemma nf_rule_to_bound_max:
  "f qs → q |∈| nf_rules R ℱ ⟹ q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))"
  by (auto simp: nf_rules_fmember)

lemma nf_rules_unique:
  assumes "f qs → q |∈| nf_rules R ℱ" and "f qs → q' |∈| nf_rules R ℱ"
  shows "q = q'" using assms unfolding nf_rules_def
  using nf_rule_to_bound_max[OF assms(1)]  nf_rule_to_bound_max[OF assms(2)]
  using bound_max_unique by blast

lemma nf_ta_det:
  shows "ta_det (nf_ta R ℱ)"
  by (auto simp add: ta_det_def nf_ta_def nf_rules_unique)

lemma term_instance_of_reach_state:
  assumes "q |∈| ta_der (nf_ta R ℱ) (adapt_vars t)" and "ground t"
  shows "q ≤b t⊥" using assms(1, 2)
proof(induct t arbitrary: q)
  case (Fun f ts)
  from Fun(2) obtain qs where wit: "f qs → q |∈| nf_rules R ℱ" "length qs = length ts"
    "∀ i < length ts. qs ! i |∈| ta_der (nf_ta R ℱ) (adapt_vars (ts ! i))"
    by (auto simp add: nf_ta_def)
  then have "BFun f qs ≤b Fun f ts⊥" using Fun(1)[OF nth_mem, of i "qs !i" for i] using Fun(3)
    by auto
  then show ?case using bless_eq_trans wit(1) bound_max_sound[of "fset R"]
    by (auto simp: nf_rules_fmember)
qed auto


lemma [simp]: "i < length ss  ⟹ l ⊳ Fun f ss ⟹ l ⊳ ss ! i"
  by (meson nth_mem subterm.dual_order.strict_trans supt.arg)

lemma subt_less_eq_res_less_eq:
  assumes ground: "ground t" and "l |∈| R" and "l ⊳ s" and "s⊥ ≤b t⊥"
    and "q |∈| ta_der (nf_ta R ℱ) (adapt_vars t)"
  shows "s⊥ ≤b q" using assms(2-)
proof (induction t arbitrary: q s)
  case (Var x)
  then show ?case using lift_total.anti_sym by fastforce
next
  case (Fun f ts) note IN = this
  from IN obtain qs where rule: "f qs → q |∈| nf_rules R ℱ" and
    reach: "length qs = length ts" "∀ i < length ts. qs ! i |∈| ta_der (nf_ta R ℱ) (adapt_vars (ts ! i))"
    by (auto simp add: nf_ta_def)
  have q: "lift_sup_small (BFun f qs) (psubt_lhs_bot (fset R)) = Some q"
    using nf_rule_to_bound_max[OF rule] 
    using lift_total.supremum_smaller_exists_unique[OF finite_lhs_subt, of "fset R" "BFun f qs"]
    by simp (metis option.collapse option.distinct(1))
  have subst: "s⊥ ≤b BFun f qs" using IN(1)[OF nth_mem, of i "term.args s ! i" "qs ! i" for i] IN(2-) reach
    by (cases s) (auto elim!: bless_eq.cases)
  have "s⊥ ∈ psubt_lhs_bot (fset R)" using Fun(2 - 4)
    by auto (metis notin_fset)
  then have "lift_total.lifted_less_eq (Some (s⊥)) (lift_sup_small (BFun f qs) (psubt_lhs_bot (fset R)))"
    using subst
    by (intro lift_total.lift_ord.supremum_sound)
     (auto simp: lift_total.lift_ord.smaller_subset_def)
  then show ?case using subst q finite_lhs_subt
    by auto
qed

lemma ta_nf_sound1:
  assumes ground: "ground t" and lhs: "l |∈| R" and inst: "l⊥ ≤b t⊥"
  shows "ta_der (nf_ta R ℱ) (adapt_vars t) = {||}"
proof (rule ccontr)
  assume ass: "ta_der (nf_ta R ℱ) (adapt_vars t) ≠ {||}"
  show False proof (cases t)
    case [simp]: (Fun f ts) from ass
    obtain q qs where fin: "q |∈| ta_der (nf_ta R ℱ) (adapt_vars (Fun f ts))" and
      rule: "(f qs → q) |∈| rules (nf_ta R ℱ)" "length qs = length ts" and
      reach: "∀ i < length ts. qs ! i |∈| ta_der (nf_ta R ℱ) (adapt_vars (ts ! i))"
      by (auto simp add: nf_ta_def) blast
    have "l⊥ ≤b  BFun f qs" using reach assms(1) inst rule(2)
      using subt_less_eq_res_less_eq[OF _ lhs, of "ts ! i" "term.args l ! i" "qs ! i" ℱ for i]
        by (cases l) (auto elim!: bless_eq.cases intro!: bless_eq.step)
    then show ?thesis using lhs rule by (auto simp: nf_ta_def nf_rules_def)
  qed (metis ground ground.simps(1))
qed

lemma ta_nf_tr_to_state:
  assumes "ground t" and "q |∈| ta_der (nf_ta R ℱ) (adapt_vars t)"
  shows "q |∈| fstates R" using assms bound_max_state_fset
  by (cases t) (auto simp: states_def nf_ta_def nf_rules_def)

lemma ta_nf_sound2:
  assumes linear: "∀ l |∈| R. linear_term l"
    and "ground (t :: ('f, 'v) term)" and "funas_term t ⊆ fset ℱ"
    and NF: "⋀ l s. l |∈| R ⟹ t ⊵ s ⟹ ¬ l⊥ ≤b s⊥"
  shows "∃ q. q |∈| ta_der (nf_ta R ℱ) (adapt_vars t)" using assms(2 - 4)
proof (induct t)
  case (Fun f ts)
  have sub: "⋀ i. i < length ts ⟹ (⋀l s. l |∈| R ⟹ ts ! i ⊵ s ⟹ ¬ l⊥ ≤b s⊥) " using Fun(4) nth_mem by blast
  from Fun(1)[OF nth_mem] this Fun(2, 3) obtain qs where
    reach: "(∀ i < length ts. qs ! i |∈| ta_der (nf_ta R ℱ) (adapt_vars (ts ! i)))" and len: "length qs = length ts"
    using Ex_list_of_length_P[of "length ts" "λ x i. x |∈| (ta_der (nf_ta R ℱ) (adapt_vars (ts ! i)))"]
    by auto (meson UN_subset_iff nth_mem)
  have nt_inst: "¬ (∃ s |∈| R. s⊥ ≤b BFun f qs)"
  proof (rule ccontr, simp)
    assume ass: "∃ s |∈| R. s⊥ ≤b BFun f qs"
    from term_instance_of_reach_state[of "qs ! i" R ℱ "ts ! i" for i] reach Fun(2) len
    have "BFun f qs ≤b Fun f ts⊥" by auto
    then show False using ass Fun(4) bless_eq_trans by blast
  qed
  obtain q where "q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))" by blast
  then have "f qs → q |∈| rules (nf_ta R ℱ)" using Fun(2 - 4)
    using ta_nf_tr_to_state[of "ts ! i" "qs ! i" R ℱ for i] len nt_inst reach
    by (auto simp: nf_ta_def nf_rules_fmember, simp add: fmember.rep_eq)
       (metis (no_types, lifting) in_fset_idx nth_mem)
  then show ?case using reach len by auto
qed auto

lemma ta_nf_lang_sound:
  assumes "l |∈| R"
  shows "C⟨l ⋅ σ⟩ ∉ ta_lang (fstates R) (nf_ta R ℱ)"
proof (rule ccontr, simp del: ta_lang_to_gta_lang)
  assume *: "C⟨l ⋅ σ⟩ ∈ ta_lang (fstates R) (nf_ta R ℱ)"
  then have cgr:"ground (C⟨l⋅σ⟩)" unfolding ta_lang_def by force
  then have gr: "ground (l ⋅ σ)" by simp
  then have  "l⊥ ≤b (l ⋅ σ)⊥" using instance_to_bless_eq by blast 
  from ta_nf_sound1[OF gr assms(1) this] have res: "ta_der (nf_ta R ℱ) (adapt_vars (l ⋅ σ)) = {||}" .
  from ta_langE * obtain q where "q |∈| ta_der (nf_ta R ℱ) (adapt_vars (C⟨l⋅σ⟩))"
    by (metis adapt_vars_adapt_vars)
  with ta_der_ctxt_decompose[OF this[unfolded adapt_vars_ctxt]] res
  show False by blast
qed

lemma ta_nf_lang_complete:
  assumes linear: "∀ l |∈| R. linear_term l"
      and ground: "ground (t :: ('f, 'v) term)" and sig: "funas_term t ⊆ fset ℱ"
      and nf: "⋀C σ l. l |∈| R ⟹ C⟨l⋅σ⟩ ≠ t"
    shows "t ∈ ta_lang (fstates R) (nf_ta R ℱ)"
proof -
  from nf have "⋀ l s. l |∈| R ⟹ t ⊵ s ⟹ ¬ l⊥ ≤b s⊥"
    using bless_eq_to_instance linear by blast
  from ta_nf_sound2[OF linear ground sig] this
  obtain q where "q |∈| ta_der (nf_ta R ℱ) (adapt_vars t)" by blast
  from this ta_nf_tr_to_state[OF ground this] ground show ?thesis
    by (intro ta_langI) (auto simp add: nf_ta_def)
qed

lemma ta_nf_ℒ_complete:
  assumes linear: "∀ l |∈| R. linear_term l"
      and sig: "funas_gterm t ⊆ fset ℱ"
      and nf: "⋀C σ l. l |∈| R ⟹ C⟨l⋅σ⟩ ≠ (term_of_gterm t)"
    shows "t ∈ ℒ (nf_reg R ℱ)"
  using ta_nf_lang_complete[of R "term_of_gterm t" ℱ] assms
  by (force simp: ℒ_def nf_reg_def funas_term_of_gterm_conv)

lemma nf_ta_funas:
  assumes "ground t" "q |∈| ta_der (nf_ta R ℱ) t"
  shows "funas_term t ⊆ fset ℱ" using assms
proof (induct t arbitrary: q)
  case (Fun f ts)
  from Fun(2-) have "(f, length ts) |∈| ℱ"
    by (auto simp: nf_ta_def nf_rules_def)
  then show ?case using Fun
    by (auto simp: fmember.rep_eq) (metis Fun.hyps Fun.prems(2) in_set_idx subsetD ta_der_Fun)
qed auto

lemma gta_lang_nf_ta_funas:
  assumes "t ∈ ℒ (nf_reg R ℱ)"
  shows "funas_gterm t ⊆ fset ℱ" using assms nf_ta_funas[of "term_of_gterm t" _ R ℱ]
  unfolding nf_reg_def ℒ_def
  by (auto simp: funas_term_of_gterm_conv)

end
tle>

Theory Tree_Automata_Derivation_Split

theory Tree_Automata_Derivation_Split
  imports Regular_Tree_Relations.Tree_Automata
    Ground_MCtxt
begin

lemma ta_der'_inf_mctxt:
  assumes "t |∈| ta_der' 𝒜 s"
  shows "fst (split_vars t) ≤ (mctxt_of_term s)" using assms
proof (induct s arbitrary: t)
  case (Fun f ts) then show ?case
    by (cases t) (auto simp: comp_def less_eq_mctxt_prime intro: less_eq_mctxt'.intros)
qed (auto simp: ta_der'.simps)

lemma ta_der'_poss_subt_at_ta_der':
  assumes "t |∈| ta_der' 𝒜 s" and "p ∈ poss t"
  shows "t |_ p |∈| ta_der' 𝒜 (s |_ p)" using assms
  by (induct s arbitrary: t p) (auto simp: ta_der'.simps, blast+)

lemma ta_der'_varposs_to_ta_der:
  assumes "t |∈| ta_der' 𝒜 s" and "p ∈ varposs t"
  shows "the_Var (t |_ p) |∈| ta_der 𝒜 (s |_ p)" using assms
  by (induct s arbitrary: t p) (auto simp: ta_der'.simps, blast+)

definition "ta_der'_target_mctxt t ≡ fst (split_vars t)"
definition "ta_der'_target_args t ≡  snd (split_vars t)"
definition "ta_der'_source_args t s ≡ unfill_holes (fst (split_vars t)) s"

lemmas ta_der'_mctxt_simps = ta_der'_target_mctxt_def ta_der'_target_args_def ta_der'_source_args_def

lemma ta_der'_target_mctxt_funas [simp]:
  "funas_mctxt (ta_der'_target_mctxt u) = funas_term u"
  by (auto simp: ta_der'_target_mctxt_def)

lemma ta_der'_target_mctxt_ground [simp]:
  "ground_mctxt (ta_der'_target_mctxt t)"
  by (auto simp: ta_der'_target_mctxt_def)

lemma ta_der'_source_args_ground:
  "t |∈| ta_der' 𝒜 s ⟹ ground s ⟹ ∀ u ∈ set (ta_der'_source_args t s). ground u"
  by (metis fill_unfill_holes ground_fill_holes length_unfill_holes ta_der'_inf_mctxt ta_der'_mctxt_simps)

lemma ta_der'_source_args_term_of_gterm:
  "t |∈| ta_der' 𝒜 (term_of_gterm s) ⟹ ∀ u ∈ set (ta_der'_source_args t (term_of_gterm s)). ground u"
  by (intro ta_der'_source_args_ground) auto

lemma ta_der'_source_args_length: 
  "t |∈| ta_der' 𝒜 s ⟹ num_holes (ta_der'_target_mctxt t) = length (ta_der'_source_args t s)"
  by (auto simp: ta_der'_mctxt_simps ta_der'_inf_mctxt)

lemma ta_der'_target_args_length: 
  "num_holes (ta_der'_target_mctxt t) = length (ta_der'_target_args t)"
  by (auto simp: ta_der'_mctxt_simps split_vars_num_holes)

lemma ta_der'_target_args_vars_term_conv:
  "vars_term t = set (ta_der'_target_args t)"
  by (auto simp: ta_der'_target_args_def split_vars_vars_term_list)

lemma ta_der'_target_args_vars_term_list_conv:
  "ta_der'_target_args t = vars_term_list t"
  by (auto simp: ta_der'_target_args_def split_vars_vars_term_list)


lemma mctxt_args_ta_der':
  assumes "num_holes C = length qs" "num_holes C = length ss" 
    and "∀ i < length ss. qs ! i |∈| ta_der 𝒜 (ss ! i)"
  shows "(fill_holes C (map Var qs)) |∈| ta_der' 𝒜 (fill_holes C ss)" using assms
proof (induct rule: fill_holes_induct2)
  case MHole then show ?case
    by (cases ss; cases qs) (auto simp: ta_der_to_ta_der')
next
  case (MFun f ts) then show ?case
    by (simp add: partition_by_nth_nth(1, 2))
qed auto

― ‹Splitting derivation into multihole context containing the remaining function symbols and
  the states, where each state is reached via the automata›
lemma ta_der'_mctxt_structure:
  assumes "t |∈| ta_der' 𝒜 s"
  shows "t = fill_holes (ta_der'_target_mctxt t) (map Var (ta_der'_target_args t))" (is "?G1")
    "s = fill_holes (ta_der'_target_mctxt t) (ta_der'_source_args t s)" (is "?G2")
    "num_holes (ta_der'_target_mctxt t) = length (ta_der'_source_args t s) ∧
     length (ta_der'_source_args t s) = length (ta_der'_target_args t)" (is "?G3")
    "i < length (ta_der'_source_args t s) ⟹ ta_der'_target_args t ! i |∈| ta_der 𝒜 (ta_der'_source_args t s ! i)"
proof -
  let ?C = "ta_der'_target_mctxt t" let ?ss = "ta_der'_source_args t s"
  let ?qs = "ta_der'_target_args t"
  have t_split: "?G1" by (auto simp: ta_der'_mctxt_simps split_vars_fill_holes)
  have s_split: "?G2" by (auto simp: ta_der'_mctxt_simps ta_der'_inf_mctxt[OF assms]
     intro!: fill_unfill_holes[symmetric])
  have len: "num_holes ?C = length ?ss" "length ?ss = length ?qs" using assms
    by (auto simp: ta_der'_mctxt_simps split_vars_num_holes ta_der'_inf_mctxt)
  have "i < length (ta_der'_target_args t) ⟹
       ta_der'_target_args t ! i |∈| ta_der 𝒜 (ta_der'_source_args t s ! i)" for i
    using ta_der'_poss_subt_at_ta_der'[OF assms, of "varposs_list t ! i"]
    unfolding ta_der'_mctxt_simps split_vars_vars_term_list length_map 
    by (auto simp: unfill_holes_to_subst_at_hole_poss[OF ta_der'_inf_mctxt[OF assms]]
       simp flip: varposs_list_to_var_term_list[of i t, unfolded varposs_list_var_terms_length])
       (metis assms hole_poss_split_vars_varposs_list nth_map nth_mem
        ta_der'_varposs_to_ta_der ta_der_to_ta_der' varposs_eq_varposs_list varposs_list_var_terms_length)
  then show ?G1 ?G2 ?G3 "i < length (ta_der'_source_args t s) ⟹
       ta_der'_target_args t ! i |∈| ta_der 𝒜 (ta_der'_source_args t s ! i)" using len t_split s_split
    by (simp_all add: ta_der'_mctxt_simps)
qed

lemma ta_der'_ground_mctxt_structure:
  assumes "t |∈| ta_der' 𝒜 (term_of_gterm s)"
  shows "t = fill_holes (ta_der'_target_mctxt t) (map Var (ta_der'_target_args t))"
    "term_of_gterm s = fill_holes (ta_der'_target_mctxt t) (ta_der'_source_args t (term_of_gterm s))"
    "num_holes (ta_der'_target_mctxt t) =  length (ta_der'_source_args t (term_of_gterm s)) ∧
     length (ta_der'_source_args t (term_of_gterm s)) = length (ta_der'_target_args t)"
    "i < length (ta_der'_target_args t) ⟹ ta_der'_target_args t ! i |∈| ta_der 𝒜 (ta_der'_source_args t (term_of_gterm s) ! i)"
  using ta_der'_mctxt_structure[OF assms]
  by force+


― ‹Splitting derivation into context containing the remaining function symbols and state›

definition "ta_der'_gctxt t ≡ gctxt_of_gmctxt (gmctxt_of_mctxt (fst (split_vars t)))"
abbreviation "ta_der'_ctxt t ≡ ctxt_of_gctxt (ta_der'_gctxt t)"
definition "ta_der'_source_ctxt_arg t s ≡ hd (unfill_holes (fst (split_vars t)) s)"

abbreviation "ta_der'_source_gctxt_arg t s ≡ gterm_of_term (ta_der'_source_ctxt_arg t (term_of_gterm s))"

lemma ta_der'_ctxt_structure:
  assumes "t |∈| ta_der' 𝒜 s" "vars_term_list t = [q]"
  shows "t = (ta_der'_ctxt t)⟨Var q⟩" (is "?G1")
    "s = (ta_der'_ctxt t)⟨ta_der'_source_ctxt_arg t s⟩" (is "?G2")
    "ground_ctxt (ta_der'_ctxt t)" (is "?G3")
    "q |∈| ta_der 𝒜 (ta_der'_source_ctxt_arg t s)" (is "?G4")
proof -
  have *: "length xs = Suc 0 ⟹ xs = [hd xs]" for xs
    by (metis length_0_conv length_Suc_conv list.sel(1))
  have [simp]: "length (snd (split_vars t)) = Suc 0" using assms(2) ta_der'_inf_mctxt[OF assms(1)]
    by (auto simp: split_vars_vars_term_list)
  have [simp]: "num_gholes (gmctxt_of_mctxt (fst (split_vars t))) = Suc 0" using assms(2)
    by (simp add: split_vars_num_holes split_vars_vars_term_list)
  have [simp]: "ta_der'_source_args t s = [ta_der'_source_ctxt_arg t s]"
    using assms(2) ta_der'_inf_mctxt[OF assms(1)]
    by (auto simp: ta_der'_source_args_def ta_der'_source_ctxt_arg_def split_vars_num_holes intro!: *)
  have t_split: ?G1 using assms(2)
    by (auto simp: ta_der'_gctxt_def split_vars_fill_holes
      split_vars_vars_term_list simp flip: ctxt_of_gctxt_gctxt_of_gmctxt_apply)
  have s_split: ?G2 using ta_der'_mctxt_structure[OF assms(1)] assms(2)
    by (auto simp: ta_der'_gctxt_def ta_der'_target_mctxt_def
          simp flip: ctxt_of_gctxt_gctxt_of_gmctxt_apply)
  from ta_der'_mctxt_structure[OF assms(1)] have ?G4
    by (auto simp: ta_der'_target_args_def assms(2) split_vars_vars_term_list)
  moreover have ?G3 unfolding ta_der'_gctxt_def by auto
  ultimately show ?G1 ?G2 ?G3 ?G4 using t_split s_split
    by force+
qed


lemma ta_der'_ground_ctxt_structure:
  assumes "t |∈| ta_der' 𝒜 (term_of_gterm s)" "vars_term_list t = [q]"
  shows "t = (ta_der'_ctxt t)⟨Var q⟩"
    "s = (ta_der'_gctxt t)⟨ta_der'_source_gctxt_arg t s⟩G"
    "ground (ta_der'_source_ctxt_arg t (term_of_gterm s))"
    "q |∈| ta_der 𝒜 (ta_der'_source_ctxt_arg t (term_of_gterm s))"
  using ta_der'_ctxt_structure[OF assms] term_of_gterm_ctxt_apply
  by force+

subsection ‹Sufficient condition for splitting the reachability relation induced by a tree automaton›

locale derivation_split =
  fixes A :: "('q, 'f) ta" and 𝒜 and ℬ
  assumes rule_split: "rules A = rules 𝒜 |∪| rules ℬ"
    and eps_split: "eps A = eps 𝒜 |∪| eps ℬ"
    and B_target_states: "rule_target_states (rules ℬ) |∪| (snd |`| (eps ℬ)) |∩|
      (rule_arg_states (rules 𝒜) |∪| (fst |`| (eps 𝒜))) = {||}"
begin

abbreviation "ΔA ≡ rules 𝒜"
abbreviation "ΔℰA ≡ eps 𝒜"
abbreviation "ΔB ≡ rules ℬ"
abbreviation "ΔℰB ≡ eps ℬ"

abbreviation "𝒬A ≡ 𝒬 𝒜"
definition "𝒬B ≡ rule_target_states ΔB |∪| (snd |`| ΔℰB)"
lemmas B_target_states' = B_target_states[folded 𝒬B_def]

lemma states_split [simp]: "𝒬 A = 𝒬 𝒜 |∪| 𝒬 ℬ"
  by (auto simp add: 𝒬_def rule_split eps_split)

lemma A_args_states_not_B:
  "TA_rule f qs q |∈| ΔA ⟹ p |∈| fset_of_list qs ⟹ p |∉| 𝒬B"
  using B_target_states
  by (force simp add: 𝒬B_def)

lemma rule_statesD:
  "r |∈| ΔA ⟹ r_rhs r |∈| 𝒬A"
  "r |∈| ΔB ⟹ r_rhs r |∈| 𝒬B"
  "r |∈| ΔA ⟹ p |∈| fset_of_list (r_lhs_states r) ⟹ p |∈| 𝒬A"
  "TA_rule f qs q |∈| ΔA ⟹ q |∈| 𝒬A"
  "TA_rule f qs q |∈| ΔB ⟹ q |∈| 𝒬B"
  "TA_rule f qs q |∈| ΔA ⟹ p |∈| fset_of_list qs ⟹ p |∈| 𝒬A"
  by (auto simp: rule_statesD 𝒬B_def rev_fimage_eqI)

lemma eps_states_dest:
  "(p, q) |∈| ΔℰA ⟹ p |∈| 𝒬A"
  "(p, q) |∈| ΔℰA ⟹ q |∈| 𝒬A"
  "(p, q) |∈| ΔℰA|+| ⟹ p |∈| 𝒬A"
  "(p, q) |∈| ΔℰA|+| ⟹ q |∈| 𝒬A"
  "(p, q) |∈| ΔℰB ⟹ q |∈| 𝒬B"
  "(p, q) |∈| ΔℰB|+| ⟹ q |∈| 𝒬B"
  by (auto simp: eps_dest_all 𝒬B_def rev_fimage_eqI elim: ftranclE)

lemma transcl_eps_simp:
  "(eps A)|+| = ΔℰA|+| |∪| ΔℰB|+| |∪| (ΔℰA|+| |O| ΔℰB|+|)"
proof -
  have "ΔℰB |O| ΔℰA = {||}" using B_target_states'
    by (metis eps_states_dest(5) ex_fin_conv fimageI finterI frelcompE fst_conv inf_sup_distrib1 sup_eq_bot_iff)
  from ftrancl_Un2_separatorE[OF this] show ?thesis
    unfolding eps_split by auto
qed

lemma B_rule_eps_A_False:
  "f qs → q |∈| ΔB ⟹ (q, p) |∈| ΔℰA|+| ⟹ False"
  using B_target_states unfolding 𝒬B_def
  by (metis B_target_states' equalsffemptyD fimage_eqI finter_iff fst_conv ftranclD funion_iff local.rule_statesD(5))

lemma to_A_rule_set:
  assumes "TA_rule f qs q |∈| rules A" and "q = p ∨ (q, p) |∈| (eps A)|+|" and "p |∉| 𝒬B"
  shows "TA_rule f qs q |∈| ΔA" "q = p ∨ (q, p) |∈| ΔℰA|+|" using assms
  unfolding transcl_eps_simp rule_split
  by (auto dest: rule_statesD eps_states_dest dest: B_rule_eps_A_False)

lemma to_B_rule_set:
  assumes "TA_rule f qs q |∈| rules A" and "q |∉| 𝒬A"
  shows "TA_rule f qs q |∈| ΔB" using assms
  unfolding transcl_eps_simp rule_split
  by (auto dest: rule_statesD eps_states_dest)


declare fsubsetI[rule del]
lemma ta_der_monos:
  "ta_der 𝒜 t |⊆| ta_der A t" "ta_der ℬ t |⊆| ta_der A t"
  by (auto simp: sup.coboundedI1 rule_split eps_split intro!: ta_der_mono)
declare fsubsetI[intro!]


lemma ta_der_from_ΔA:
  assumes "q |∈| ta_der A (term_of_gterm t)" and "q |∉| 𝒬B"
  shows "q |∈| ta_der 𝒜 (term_of_gterm t)" using assms
proof (induct rule: ta_der_gterm_induct)
  case (GFun f ts ps p q)
  have "i < length ts ⟹ ps ! i |∉| 𝒬B" for i using GFun A_args_states_not_B
    by (metis fnth_mem to_A_rule_set(1))
  then show ?case using GFun(2, 5) to_A_rule_set[OF GFun(1, 3, 6)]
    by (auto simp: transcl_eps_simp)
qed

lemma ta_state:
  assumes "q |∈| ta_der A (term_of_gterm s)"
  shows "q |∈| 𝒬A ∨ q |∈| 𝒬B" using assms
  by (cases s) (auto simp: rule_split transcl_eps_simp dest: rule_statesD eps_states_dest)

(* Main lemmas *)

lemma ta_der_split:
  assumes "q |∈| ta_der A (term_of_gterm s)" and "q |∈| 𝒬B"
  shows "∃ t. t |∈| ta_der' 𝒜 (term_of_gterm s) ∧ q |∈| ta_der ℬ t"
    (is "∃t . ?P s q t") using assms
proof (induct rule: ta_der_gterm_induct)
  case (GFun f ts ps p q)
  {fix i assume ass: "i < length ts"
    then have "∃ t. t |∈| ta_der' 𝒜 (term_of_gterm (ts ! i)) ∧ ps ! i |∈| ta_der ℬ t"
    proof (cases "ps ! i |∉| 𝒬B")
      case True then show ?thesis
        using ta_state GFun(2, 4) ta_der_from_ΔA[of "ps ! i" "ts ! i"] ass
        by (intro exI[of _ "Var (ps ! i)"]) (auto simp: ta_der_to_ta_der' 𝒬B_def)
    next
      case False
      then have "ps ! i |∈| 𝒬B" using ta_state[OF GFun(4)[OF ass]]
        by auto 
      from GFun(5)[OF ass this] show ?thesis .
    qed}
  then obtain h where IH:
    "∀ i < length ts. h i |∈| ta_der' 𝒜 (term_of_gterm (ts ! i))"
    "∀ i < length ts. ps ! i |∈| ta_der ℬ (h i)"
    using GFun(1 - 4) choice_nat[of "length ts" "λ t i. ?P (ts ! i) (ps ! i) t"]
    by blast
  from GFun(1) consider (A) "f ps → p |∈| ΔA" | (B) "f ps → p |∈| ΔB" by (auto simp: rule_split)
  then show ?case
  proof cases
    case A then obtain q' where eps_sp: "p = q' ∨ (p, q') |∈| ΔℰA|+|"
      "q' = q ∨ (q', q) |∈| ΔℰB|+|" using GFun(3, 6)
      by (auto simp: transcl_eps_simp dest: eps_states_dest)
    from GFun(4)[THEN ta_der_from_ΔA] A GFun(2, 4)
    have reach_fst: "p |∈| ta_der 𝒜 (term_of_gterm (GFun f ts))"
      using A_args_states_not_B by auto
    then have "q' |∈| ta_der 𝒜 (term_of_gterm (GFun f ts))" using eps_sp
      by (meson ta_der_trancl_eps)
    then show ?thesis using eps_sp(2)
      by (intro exI[of _ "Var q'"]) (auto simp flip: ta_der_to_ta_der' simp del: ta_der'_simps)
  next
    case B
    then have "p = q ∨ (p, q) |∈| ΔℰB|+|" using GFun(3)
      by (auto simp: transcl_eps_simp dest: B_rule_eps_A_False)
    then show ?thesis using GFun(2, 4, 6) IH B
      by (auto intro!: exI[of _ "Fun f (map h [0 ..< length ts])"] exI[of _ ps])
  qed
qed


lemma ta_der'_split:
  assumes "t |∈| ta_der' A (term_of_gterm s)"
  shows "∃ u. u |∈| ta_der' 𝒜 (term_of_gterm s) ∧ t |∈| ta_der' ℬ u"
    (is "∃ u. ?P s t u") using assms
proof (induct s arbitrary: t)
  case (GFun f ts) show ?case
  proof (cases t)
    case [simp]: (Var q)
    have "q |∈| ta_der A (term_of_gterm (GFun f ts))" using GFun(2)
      by (auto simp flip: ta_der_to_ta_der')
    from ta_der_split[OF this] ta_der_from_ΔA[OF this] ta_state[OF this]
    show ?thesis unfolding Var
      by (metis ta_der'_refl ta_der_to_ta_der')
  next
    case [simp]: (Fun g ss)
    obtain h where IH:
      "∀ i < length ts. h i |∈| ta_der' 𝒜 (term_of_gterm (ts ! i))"
      "∀ i < length ts. ss ! i |∈| ta_der' ℬ (h i)"
      using GFun choice_nat[of "length ts" "λ t i. ?P (ts ! i) (ss ! i) t"]
      by auto
    then show ?thesis using GFun(2)
      by (auto intro!: exI[of _ "Fun f (map h [0..<length ts])"])
  qed
qed

(* TODO rewrite using ta_der'_mctxt_structure *)
lemma ta_der_to_mcxtx:
  assumes "q |∈| ta_der A (term_of_gterm s)" and "q |∈| 𝒬B"
  shows "∃ C ss qs. length qs = length ss ∧ num_holes C = length ss ∧
    (∀ i < length ss. qs ! i |∈| ta_der 𝒜 (term_of_gterm (ss ! i))) ∧
    q |∈| ta_der ℬ (fill_holes C (map Var qs)) ∧
    ground_mctxt C ∧ fill_holes C (map term_of_gterm ss) = term_of_gterm s"
    (is "∃C ss qs. ?P s q C ss qs")
proof -
  from ta_der_split[OF assms] obtain t where
    wit: "t |∈| ta_der' 𝒜 (term_of_gterm s)" "q |∈| ta_der ℬ t" by auto
  let ?C = "fst (split_vars t)" let ?ss = "map (gsubt_at s) (varposs_list t)"
  let ?qs = "snd (split_vars t)"
  have poss [simp]:"i < length (varposs_list t) ⟹ varposs_list t ! i ∈ gposs s" for i
    by (metis nth_mem ta_der'_poss[OF wit(1)] poss_gposs_conv subset_eq varposs_eq_varposs_list
        varposs_imp_poss varposs_list_var_terms_length)
  have len: "num_holes ?C = length ?ss" "length ?ss = length ?qs"
    by (simp_all add: split_vars_num_holes split_vars_vars_term_list varposs_list_var_terms_length)
  from unfill_holes_to_subst_at_hole_poss[OF ta_der'_inf_mctxt[OF wit(1)]]
  have "unfill_holes (fst (split_vars t)) (term_of_gterm s) = map (term_of_gterm ∘ gsubt_at s) (varposs_list t)"
    by (auto simp: comp_def hole_poss_split_vars_varposs_list
        dest: in_set_idx intro!: nth_equalityI term_of_gterm_gsubt)
  from fill_unfill_holes[OF ta_der'_inf_mctxt[OF wit(1)]] this
  have rep: "fill_holes ?C (map term_of_gterm ?ss) = term_of_gterm s"
    by simp
  have reach_int: "i < length ?ss ⟹ ?qs ! i |∈| ta_der 𝒜 (term_of_gterm (?ss ! i))" for i
    using wit(1) ta_der'_varposs_to_ta_der
    unfolding split_vars_vars_term_list length_map
    unfolding varposs_list_to_var_term_list[symmetric]
    by (metis nth_map nth_mem poss term_of_gterm_gsubt varposs_eq_varposs_list)
  have reach_end: "q |∈| ta_der ℬ (fill_holes ?C (map Var ?qs))" using wit
    using split_vars_fill_holes[of ?C t "map Var ?qs"]
    by auto
  show ?thesis using len rep reach_end reach_int
    by (metis split_vars_ground')
qed

lemma ta_der_to_gmcxtx:
  assumes "q |∈| ta_der A (term_of_gterm s)" and "q |∈| 𝒬B"
  shows "∃ C ss qs qs'. length qs' = length qs ∧ length qs = length ss ∧ num_gholes C = length ss ∧
    (∀ i < length ss. qs ! i |∈| ta_der 𝒜 (term_of_gterm (ss ! i))) ∧
    q |∈| ta_der ℬ (fill_holes (mctxt_of_gmctxt C) (map Var qs')) ∧
    fill_gholes C ss = s"
  using ta_der_to_mcxtx[OF assms]
  by (metis gmctxt_of_mctxt_inv ground_gmctxt_of_gterm_of_term num_gholes_gmctxt_of_mctxt term_of_gterm_inv)

(* Reconstuction *)

lemma mctxt_const_to_ta_der:
  assumes "num_holes C = length ss" "length ss = length qs"
    and "∀ i < length qs. qs ! i |∈| ta_der 𝒜 (ss ! i)"
    and "q |∈| ta_der ℬ (fill_holes C (map Var qs))"
  shows "q |∈| ta_der A (fill_holes C ss)"
proof -
  have mid: "fill_holes C (map Var qs) |∈| ta_der' A (fill_holes C ss)"
    using assms(1 - 3) ta_der_monos(1)
    by (intro mctxt_args_ta_der') auto
  then show ?thesis using assms(1, 2) ta_der_monos(2)[THEN fsubsetD, OF assms(4)]
    using ta_der'_trans
    by (simp add: ta_der'_ta_der)
qed

lemma ctxt_const_to_ta_der:
  assumes "q |∈| ta_der 𝒜 s"
    and "p |∈| ta_der ℬ C⟨Var q⟩"
  shows "p |∈| ta_der A C⟨s⟩" using assms
  by (meson fin_mono ta_der_ctxt ta_der_monos(1) ta_der_monos(2))

lemma gctxt_const_to_ta_der:
  assumes "q |∈| ta_der 𝒜 (term_of_gterm s)"
    and "p |∈| ta_der ℬ (ctxt_of_gctxt C)⟨Var q⟩"
  shows "p |∈| ta_der A (term_of_gterm C⟨s⟩G)" using assms
  by (metis ctxt_const_to_ta_der ctxt_of_gctxt_inv ground_ctxt_of_gctxt ground_gctxt_of_ctxt_apply_gterm)

end
end

Theory TA_Clousure_Const

section ‹(Multihole)Context closure of recognized tree languages›

theory TA_Clousure_Const
  imports Tree_Automata_Derivation_Split
begin


subsection ‹Tree Automata closure constructions›
declare ta_union_def [simp]
subsubsection ‹Reflexive closure over a given signature›

definition "reflcl_rules ℱ q ≡ (λ (f, n). TA_rule f (replicate n q) q) |`| ℱ"
definition "refl_ta ℱ q = TA (reflcl_rules ℱ q) {||}"

definition gen_reflcl_automaton :: "('f × nat) fset ⇒ ('q, 'f) ta ⇒ 'q ⇒ ('q, 'f) ta" where
  "gen_reflcl_automaton ℱ 𝒜 q = ta_union 𝒜 (refl_ta ℱ q)"

definition "reflcl_automaton ℱ 𝒜 = (let ℬ = fmap_states_ta Some 𝒜 in
   gen_reflcl_automaton ℱ ℬ None)"

definition "reflcl_reg ℱ 𝒜 = Reg (finsert None (Some |`| fin 𝒜)) (reflcl_automaton ℱ (ta 𝒜))"

subsubsection ‹Multihole context closure over a given signature›

definition "refl_over_states_ta Q ℱ 𝒜 q = TA (reflcl_rules ℱ q) ((λ p. (p, q)) |`| (Q |∩| 𝒬 𝒜))"

definition gen_parallel_closure_automaton :: "'q fset ⇒ ('f × nat) fset ⇒ ('q, 'f) ta ⇒ 'q ⇒ ('q, 'f) ta" where
  "gen_parallel_closure_automaton Q ℱ 𝒜 q = ta_union 𝒜 (refl_over_states_ta Q ℱ 𝒜 q)"

definition parallel_closure_reg where
  "parallel_closure_reg ℱ 𝒜 = (let ℬ = fmap_states_reg Some 𝒜 in
   Reg {|None|} (gen_parallel_closure_automaton (fin ℬ) ℱ (ta ℬ) None))"

subsubsection ‹Context closure of regular tree language›

definition "semantic_path_rules ℱ qc qi qf ≡ 
  |⋃| ((λ (f, n). fset_of_list (map (λ i. TA_rule f ((replicate n qc)[i := qi]) qf) [0..< n])) |`| ℱ)"

definition "reflcl_over_single_ta Q ℱ qc qf ≡
  TA (reflcl_rules ℱ qc |∪| semantic_path_rules ℱ qc qf qf) ((λ p. (p, qf)) |`| Q)"

definition "gen_ctxt_closure_automaton Q ℱ 𝒜 qc qf = ta_union 𝒜 (reflcl_over_single_ta Q ℱ qc qf)"

definition "gen_ctxt_closure_reg ℱ 𝒜 qc qf =
   Reg {|qf|} (gen_ctxt_closure_automaton (fin 𝒜) ℱ (ta 𝒜) qc qf)"

definition "ctxt_closure_reg ℱ 𝒜 =
  (let ℬ = fmap_states_reg Inl (reg_Restr_Qf 𝒜) in
  gen_ctxt_closure_reg ℱ ℬ (Inr False) (Inr True))"


subsubsection ‹Not empty context closure of regular tree language›

datatype cl_states = cl_state | tr_state | fin_state | fin_clstate

definition "reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf ≡
  TA (reflcl_rules ℱ qc |∪| semantic_path_rules ℱ qc qi qf |∪| semantic_path_rules ℱ qc qf qf) ((λ p. (p, qi)) |`| Q)"

definition "gen_nhole_ctxt_closure_automaton Q ℱ 𝒜 qc qi qf =
   ta_union 𝒜 (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf)"

definition "gen_nhole_ctxt_closure_reg ℱ 𝒜 qc qi qf =
    Reg {|qf|} (gen_nhole_ctxt_closure_automaton (fin 𝒜) ℱ (ta 𝒜) qc qi qf)"

definition "nhole_ctxt_closure_reg ℱ 𝒜 =
  (let ℬ = fmap_states_reg Inl (reg_Restr_Qf 𝒜) in
  (gen_nhole_ctxt_closure_reg ℱ ℬ (Inr cl_state) (Inr tr_state) (Inr fin_state)))"

subsubsection ‹Non empty multihole context closure of regular tree language›

abbreviation "add_eps 𝒜 e ≡ TA (rules 𝒜) (eps 𝒜 |∪| e)"
definition "reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf ≡
  add_eps (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) {|(qi, qc)|}"

definition "gen_nhole_mctxt_closure_automaton Q ℱ 𝒜 qc qi qf =
   ta_union 𝒜 (reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf)"

definition "gen_nhole_mctxt_closure_reg ℱ 𝒜 qc qi qf = 
   Reg {|qf|} (gen_nhole_mctxt_closure_automaton (fin 𝒜) ℱ (ta 𝒜) qc qi qf)"

definition "nhole_mctxt_closure_reg ℱ 𝒜 =
  (let ℬ = fmap_states_reg Inl (reg_Restr_Qf 𝒜) in
  (gen_nhole_mctxt_closure_reg ℱ ℬ (Inr cl_state) (Inr tr_state) (Inr fin_state)))"

subsubsection ‹Not empty multihole context closure of regular tree language›

definition "gen_mctxt_closure_reg ℱ 𝒜 qc qi qf =
   Reg {|qf, qi|} (gen_nhole_mctxt_closure_automaton (fin 𝒜) ℱ (ta 𝒜) qc qi qf)"

definition "mctxt_closure_reg ℱ 𝒜 =
  (let ℬ = fmap_states_reg Inl (reg_Restr_Qf 𝒜) in
  (gen_mctxt_closure_reg ℱ ℬ (Inr cl_state) (Inr tr_state) (Inr fin_state)))"


subsubsection ‹Multihole context closure of regular tree language›

definition "nhole_mctxt_reflcl_reg ℱ 𝒜 =
  reg_union (nhole_mctxt_closure_reg ℱ 𝒜) (Reg {|fin_clstate|} (refl_ta ℱ (fin_clstate)))"

subsubsection ‹Lemmas about @{const ta_der'}›

lemma ta_det'_ground_id:
  "t |∈| ta_der' 𝒜 s ⟹ ground t ⟹ t = s"
  by (induct s arbitrary: t) (auto simp add: ta_der'.simps nth_equalityI)

lemma ta_det'_vars_term_id:
  "t |∈| ta_der' 𝒜 s ⟹ vars_term t ∩ fset (𝒬 𝒜) = {} ⟹ t = s"
proof (induct s arbitrary: t)
  case (Fun f ss)
  from Fun(2-) obtain ts where [simp]: "t = Fun f ts" and len: "length ts = length ss"
    by (cases t) (auto simp flip: fmember.rep_eq dest: rule_statesD eps_dest_all)
  from Fun(1)[OF nth_mem, of i "ts ! i" for i] show ?case using Fun(2-) len
    by (auto simp add: ta_der'.simps Union_disjoint simp flip: fmember.rep_eq
        dest: rule_statesD eps_dest_all intro!: nth_equalityI)
qed (auto simp add: ta_der'.simps simp flip: fmember.rep_eq dest: rule_statesD eps_dest_all)

lemma fresh_states_ta_der'_pres:
  assumes st: "q ∈ vars_term s" "q |∉| 𝒬 𝒜"
    and reach: "t |∈| ta_der' 𝒜 s"
  shows "q ∈ vars_term t" using reach st(1)
proof (induct s arbitrary: t)
  case (Var x)
  then show ?case using assms(2)
    by (cases t) (auto simp: ta_der'.simps dest: eps_trancl_statesD)
next
  case (Fun f ss)
  from Fun(3) obtain i where w: "i < length ss" "q ∈ vars_term (ss ! i)" by (auto simp: in_set_conv_nth)
  have "i < length (args t) ∧ q ∈ vars_term (args t ! i)" using Fun(2) w assms(2) Fun(1)[OF nth_mem[OF w(1)] _ w(2)]
    using rule_statesD(3) ta_der_to_ta_der'
    by (auto simp: ta_der'.simps dest: rule_statesD(3)) fastforce+
  then show ?case by (cases t) auto
qed

lemma ta_der'_states:
  "t |∈| ta_der' 𝒜 s ⟹ vars_term t ⊆ vars_term s ∪ fset (𝒬 𝒜)"
proof (induct s arbitrary: t)
  case (Var x) then show ?case
    by (auto simp: ta_der'.simps simp flip: fmember.rep_eq dest: eps_dest_all)
next
  case (Fun f ts) then show ?case
    by (auto simp: ta_der'.simps rule_statesD simp flip: fmember.rep_eq dest: eps_dest_all)
       (metis (no_types, opaque_lifting) Un_iff in_set_conv_nth notin_fset subsetD)
qed

lemma ta_der'_gterm_states:
  "t |∈| ta_der' 𝒜 (term_of_gterm s) ⟹ vars_term t ⊆ fset (𝒬 𝒜)"
  using ta_der'_states[of t 𝒜 "term_of_gterm s"]
  by auto

lemma ta_der'_Var_funas:
  "Var q |∈| ta_der' 𝒜 s ⟹ funas_term s ⊆ fset (ta_sig 𝒜)"
  by (auto simp: less_eq_fset.rep_eq ffunas_term.rep_eq dest!: ta_der_term_sig ta_der'_to_ta_der)


lemma ta_sig_fsubsetI:
  assumes "⋀ r. r |∈| rules 𝒜 ⟹ (r_root r, length (r_lhs_states r)) |∈| ℱ"
  shows "ta_sig 𝒜 |⊆| ℱ" using assms
  by (auto simp: ta_sig_def)

subsubsection ‹Signature induced by @{const refl_ta} and @{const refl_over_states_ta}›

lemma refl_ta_sig [simp]:
  "ta_sig (refl_ta ℱ q) = ℱ"
  "ta_sig (refl_over_states_ta  Q ℱ 𝒜 q ) = ℱ"
  by (auto simp: ta_sig_def refl_ta_def reflcl_rules_def refl_over_states_ta_def fimage_iff fBex_def)

subsubsection ‹Correctness of @{const refl_ta}, @{const gen_reflcl_automaton}, and @{const reflcl_automaton}›

lemma refl_ta_eps [simp]: "eps (refl_ta ℱ q) = {||}"
  by (auto simp: refl_ta_def)

lemma refl_ta_sound:
  "s ∈ 𝒯G (fset ℱ) ⟹ q |∈| ta_der (refl_ta ℱ q) (term_of_gterm s)"
  by (induct rule: 𝒯G.induct) (auto simp: refl_ta_def reflcl_rules_def
      fimage_iff fBex_def simp flip: fmember.rep_eq)

lemma reflcl_rules_args:
  "length ps = n ⟹ f ps → p |∈| reflcl_rules ℱ q ⟹ ps = replicate n q"
  by (auto simp: reflcl_rules_def)

lemma 𝒬_refl_ta:
  "𝒬 (refl_ta ℱ q) |⊆| {|q|}"
  by (auto simp: 𝒬_def refl_ta_def rule_states_def reflcl_rules_def fset_of_list_elem)

lemma refl_ta_complete1:
  "Var p |∈| ta_der' (refl_ta ℱ q) s ⟹ p ≠ q ⟹ s = Var p"
  by (cases s) (auto simp: ta_der'.simps refl_ta_def reflcl_rules_def)

lemma refl_ta_complete2:
  "Var q |∈| ta_der' (refl_ta ℱ q) s ⟹ funas_term s ⊆ fset ℱ ∧ vars_term s ⊆ {q}"
  unfolding ta_der_to_ta_der'[symmetric]
  using ta_der_term_sig[of q "refl_ta ℱ q" s] ta_der_states'[of q "refl_ta ℱ q" s]
  using fsubsetD[OF 𝒬_refl_ta[of ℱ q]]
  by (auto simp: fmember.rep_eq ffunas_term.rep_eq)
     (metis Term.term.simps(17) fresh_states_ta_der'_pres notin_fset singletonD ta_der_to_ta_der')

lemma gen_reflcl_lang:
  assumes "q |∉| 𝒬 𝒜"
  shows "gta_lang (finsert q Q) (gen_reflcl_automaton ℱ 𝒜 q) = gta_lang Q 𝒜 ∪ 𝒯G (fset ℱ)"
    (is "?Ls = ?Rs")
proof -
  let ?A = "gen_reflcl_automaton ℱ 𝒜 q"
  interpret sq: derivation_split ?A "𝒜" "refl_ta ℱ q"
    using assms unfolding derivation_split_def
    by (auto simp: gen_reflcl_automaton_def refl_ta_def reflcl_rules_def 𝒬_def)
  show ?thesis
  proof
    {fix s assume "s ∈ ?Ls" then obtain p u where
        seq: "u |∈| ta_der' 𝒜 (term_of_gterm s)" "Var p |∈| ta_der' (refl_ta ℱ q) u" and
        fin: "p |∈| finsert q Q"
        by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
      have "vars_term u ⊆ {q} ⟹ u = term_of_gterm s" using assms
        by (intro ta_det'_vars_term_id[OF seq(1)]) (auto simp flip: fmember.rep_eq)
      then have "s ∈ ?Rs" using assms fin seq funas_term_of_gterm_conv
        using refl_ta_complete1[OF seq(2)]
        by (cases "p = q") (auto simp: ta_der_to_ta_der' 𝒯G_funas_gterm_conv dest!: refl_ta_complete2)}
    then show "?Ls ⊆ gta_lang Q 𝒜 ∪ 𝒯G (fset ℱ)" by blast
  next
    show "gta_lang Q 𝒜 ∪ 𝒯G (fset ℱ) ⊆ ?Ls"
      using sq.ta_der_monos unfolding gta_lang_def gta_der_def
      by (auto dest: refl_ta_sound)
  qed
qed

lemma reflcl_lang:
  "gta_lang (finsert None (Some |`| Q)) (reflcl_automaton ℱ 𝒜) = gta_lang Q 𝒜 ∪ 𝒯G (fset ℱ)"
proof -
  have st: "None |∉| 𝒬 (fmap_states_ta Some 𝒜)" by auto
  have "gta_lang Q 𝒜 = gta_lang (Some |`| Q) (fmap_states_ta Some 𝒜)"
    by (simp add: finj_Some fmap_states_ta_lang2)
  then show ?thesis
    unfolding reflcl_automaton_def Let_def gen_reflcl_lang[OF st, of "Some |`| Q" ℱ]
    by simp
qed

lemma ℒ_reflcl_reg:
  "ℒ (reflcl_reg ℱ 𝒜) = ℒ 𝒜 ∪  𝒯G (fset ℱ)"
  by (simp add: ℒ_def reflcl_lang reflcl_reg_def )

subsubsection ‹Correctness of @{const gen_parallel_closure_automaton} and @{const parallel_closure_reg}›

lemma set_list_subset_nth_conv:
  "set xs ⊆ A ⟹ i < length xs ⟹ xs ! i ∈ A"
  by (metis in_set_conv_nth subset_code(1))

lemma ground_gmctxt_of_mctxt_fill_holes':
  "num_holes C = length ss ⟹ ground_mctxt C ⟹ ∀s∈set ss. ground s ⟹
   fill_gholes (gmctxt_of_mctxt C) (map gterm_of_term ss) = gterm_of_term (fill_holes C ss)"
  using ground_gmctxt_of_mctxt_fill_holes
  by (metis term_of_gterm_inv)


lemma refl_over_states_ta_eps_trancl [simp]:
  "(eps (refl_over_states_ta Q ℱ 𝒜 q))|+| = eps (refl_over_states_ta Q ℱ 𝒜 q)"
  using ftranclD ftranclE unfolding refl_over_states_ta_def
  by fastforce

lemma refl_over_states_ta_epsD:
  "(p, q) |∈| (eps (refl_over_states_ta Q ℱ 𝒜 q)) ⟹ p |∈| Q"
  by (auto simp: refl_over_states_ta_def)

lemma refl_over_states_ta_vars_term:
  "q |∈| ta_der (refl_over_states_ta Q ℱ 𝒜 q) u ⟹ vars_term u ⊆ insert q (fset Q)"
proof (induct u)
  case (Fun f ts)
  from Fun(2) reflcl_rules_args[of _ "length ts" f _ ℱ q]
  have "i < length ts ⟹ q |∈| ta_der (refl_over_states_ta Q ℱ 𝒜 q) (ts ! i)" for i
    by (fastforce simp: refl_over_states_ta_def)
  then have "i < length ts ⟹ x ∈ vars_term (ts ! i) ⟹ x = q ∨ x |∈| Q" for i x
    using Fun(1)[OF nth_mem, of i]
    by (meson insert_iff notin_fset subsetD)
  then show ?case by (fastforce simp: in_set_conv_nth fmember.rep_eq)
qed (auto simp flip: fmember.rep_eq dest: refl_over_states_ta_epsD)

lemmas refl_over_states_ta_vars_term' =
  refl_over_states_ta_vars_term[unfolded ta_der_to_ta_der' ta_der'_target_args_vars_term_conv,
    THEN set_list_subset_nth_conv, unfolded fmember.rep_eq[symmetric] finsert.rep_eq[symmetric]]

lemma refl_over_states_ta_sound:
  "funas_term u ⊆ fset ℱ ⟹ vars_term u ⊆ insert q (fset (Q |∩| 𝒬 𝒜)) ⟹ q |∈| ta_der (refl_over_states_ta Q ℱ 𝒜 q) u"
proof (induct u)
  case (Fun f ts)
  have reach: "i < length ts ⟹ q |∈| ta_der (refl_over_states_ta Q ℱ 𝒜 q) (ts ! i)" for i
    using Fun(2-) by (intro Fun(1)[OF nth_mem]) (auto simp: SUP_le_iff)
  from Fun(2) have "TA_rule f (replicate (length ts) q) q |∈| rules (refl_over_states_ta Q ℱ 𝒜 q)"
    by (auto simp: refl_over_states_ta_def reflcl_rules_def fimage_iff fBex_def simp flip: fmember.rep_eq)
  then show ?case using reach
    by force
qed (auto simp: refl_over_states_ta_def simp flip: fmember.rep_eq)

lemma gen_parallelcl_lang:
  fixes 𝒜 :: "('q, 'f) ta"
  assumes "q |∉| 𝒬 𝒜"
  shows "gta_lang {|q|} (gen_parallel_closure_automaton Q ℱ 𝒜 q) =
    {fill_gholes C ss | C ss. num_gholes C = length ss ∧ funas_gmctxt C ⊆ (fset ℱ) ∧ (∀ i < length ss. ss ! i ∈ gta_lang Q 𝒜)}"
    (is "?Ls = ?Rs")
proof -
  let ?A = "gen_parallel_closure_automaton Q ℱ 𝒜 q" let ?B = "refl_over_states_ta Q ℱ 𝒜 q"
  interpret sq: derivation_split "?A" "𝒜" "?B"
    using assms unfolding derivation_split_def
    by (auto simp: gen_parallel_closure_automaton_def refl_over_states_ta_def 𝒬_def reflcl_rules_def)
  {fix s assume "s ∈ ?Ls" then obtain u where
      seq: "u |∈| ta_der' 𝒜 (term_of_gterm s)" "Var q |∈| ta_der'?B u" and
      fin: "q |∈| finsert q Q"
      by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
    let ?w = "λ i. ta_der'_source_args u (term_of_gterm s) ! i"
    have "s ∈ ?Rs" using seq(1) ta_der'_Var_funas[OF seq(2)] fin
      using ground_ta_der_statesD[of "?w i" "ta_der'_target_args u ! i" 𝒜 for i] assms
      using refl_over_states_ta_vars_term'[OF seq(2)]
      using ta_der'_ground_mctxt_structure[OF seq(1)]
      by (force simp: ground_gmctxt_of_mctxt_fill_holes' ta_der'_source_args_term_of_gterm
          intro!: exI[of _ "gmctxt_of_mctxt (ta_der'_target_mctxt u)"]
          exI[of _ "map gterm_of_term (ta_der'_source_args u (term_of_gterm s))"]
          gta_langI[of "ta_der'_target_args u ! i" Q 𝒜
            "gterm_of_term (?w i)" for i])}
  then have ls: "?Ls ⊆ ?Rs" by blast
  {fix t assume "t ∈ ?Rs"
    then obtain C ss where len: "num_gholes C = length ss" and
      gr_fun: "funas_gmctxt C ⊆ fset ℱ" and
      reachA: "∀ i < length ss. ss ! i ∈ gta_lang Q 𝒜" and
      const: "t = fill_gholes C ss" by auto
    from reachA obtain qs where "length ss = length qs" "∀ i < length qs. qs ! i |∈| Q |∩| 𝒬 𝒜"
      "∀ i < length qs. qs ! i |∈| ta_der 𝒜 ((map term_of_gterm ss) ! i)"
      using Ex_list_of_length_P[of "length ss" "λ q i. q |∈| ta_der 𝒜 (term_of_gterm (ss ! i)) ∧ q |∈| Q"]
      by (metis (full_types) finterI gta_langE gterm_ta_der_states length_map map_nth_eq_conv)
    then have "q |∈| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
      using reachA len gr_fun
      by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q])
        (auto simp: funas_mctxt_of_gmctxt_conv simp flip: fmember.rep_eq
          dest!: in_set_idx intro!: refl_over_states_ta_sound)
    then have "t ∈ ?Ls" unfolding const
      by (simp add: fill_holes_mctxt_of_gmctxt_to_fill_gholes gta_langI len)}
  then show ?thesis using ls by blast
qed

lemma parallelcl_gmctxt_lang:
  fixes 𝒜 :: "('q, 'f) reg"
  shows "ℒ (parallel_closure_reg ℱ 𝒜) =
    {fill_gholes C ss |
      C ss. num_gholes C = length ss ∧ funas_gmctxt C ⊆ fset ℱ ∧ (∀ i < length ss. ss ! i ∈ ℒ 𝒜)}"
proof -
  have *: "gta_lang (fin (fmap_states_reg Some 𝒜)) (fmap_states_ta Some (ta 𝒜)) = gta_lang (fin 𝒜) (ta 𝒜)"
    by (simp add: finj_Some fmap_states_reg_def fmap_states_ta_lang2)
  have " None |∉| 𝒬 (fmap_states_ta Some (ta 𝒜))" by auto
  from gen_parallelcl_lang[OF this, of "fin (fmap_states_reg Some 𝒜)" ℱ] show ?thesis
    unfolding ℒ_def parallel_closure_reg_def Let_def * fmap_states_reg_def
    by (simp add: finj_Some fmap_states_ta_lang2)
qed

lemma parallelcl_mctxt_lang:
  shows "ℒ (parallel_closure_reg ℱ 𝒜) =
    {(gterm_of_term :: ('f, 'q option) term ⇒ 'f gterm) (fill_holes C (map term_of_gterm ss)) |
      C ss. num_holes C = length ss ∧ ground_mctxt C ∧ funas_mctxt C ⊆ fset ℱ ∧ (∀ i < length ss. ss ! i ∈ ℒ 𝒜)}"
  by (auto simp: parallelcl_gmctxt_lang) (metis funas_gmctxt_of_mctxt num_gholes_gmctxt_of_mctxt
      ground_gmctxt_of_gterm_of_term funas_mctxt_of_gmctxt_conv
      ground_mctxt_of_gmctxt mctxt_of_gmctxt_fill_holes num_holes_mctxt_of_gmctxt)+ 

subsubsection ‹Correctness of @{const gen_ctxt_closure_reg} and @{const ctxt_closure_reg}›

lemma semantic_path_rules_rhs:
  "r |∈| semantic_path_rules Q qc qi qf ⟹ r_rhs r = qf"
  by (auto simp: semantic_path_rules_def)

lemma reflcl_over_single_ta_transl [simp]:
  "(eps (reflcl_over_single_ta Q ℱ qc qf))|+| = eps (reflcl_over_single_ta Q ℱ qc qf)"
  using ftranclD ftranclE unfolding reflcl_over_single_ta_def
  by fastforce

lemma reflcl_over_single_ta_epsD:
  "(p, qf) |∈| eps (reflcl_over_single_ta Q ℱ qc qf) ⟹ p |∈| Q"
  "(p, q) |∈| eps (reflcl_over_single_ta Q ℱ qc qf) ⟹ q = qf"
  by (auto simp: reflcl_over_single_ta_def)

lemma reflcl_over_single_ta_rules_split:
  "r |∈| rules (reflcl_over_single_ta Q ℱ qc qf) ⟹
     r |∈| reflcl_rules ℱ qc ∨ r |∈| semantic_path_rules ℱ qc qf qf"
  by (auto simp: reflcl_over_single_ta_def)

lemma reflcl_over_single_ta_rules_semantic_path_rulesI:
  "r |∈| semantic_path_rules ℱ qc qf qf ⟹ r |∈| rules (reflcl_over_single_ta Q ℱ qc qf)"
  by (auto simp: reflcl_over_single_ta_def)

lemma semantic_path_rules_fmember [intro]:
  "TA_rule f qs q |∈| semantic_path_rules ℱ qc qi qf ⟷ (∃ n i. (f, n) |∈| ℱ ∧ i < n ∧ q = qf ∧
    (qs = (replicate n qc)[i := qi]))" (is "?Ls ⟷ ?Rs")
  by (force simp: semantic_path_rules_def fBex_def fimage_iff fset_of_list_elem)

lemma semantic_path_rules_fmemberD:
  "r |∈| semantic_path_rules ℱ qc qi qf ⟹ (∃ n i. (r_root r, n) |∈| ℱ ∧ i < n ∧ r_rhs r = qf ∧
    (r_lhs_states r = (replicate n qc)[i := qi]))"
  by (cases r) (simp add: semantic_path_rules_fmember) 


lemma reflcl_over_single_ta_vars_term_qc:
  "qc ≠ qf ⟹ qc |∈| ta_der (reflcl_over_single_ta Q ℱ qc qf) u ⟹
    vars_term_list u = replicate (length (vars_term_list u)) qc"
proof (induct u)
  case (Fun f ts)
  have "i < length ts ⟹ qc |∈| ta_der (reflcl_over_single_ta Q ℱ qc qf) (ts ! i)" for i using Fun(2, 3)
    by (auto dest!: reflcl_over_single_ta_rules_split reflcl_over_single_ta_epsD
        reflcl_rules_args semantic_path_rules_rhs)
  then have "i < length (concat (map vars_term_list ts)) ⟹ concat (map vars_term_list ts) ! i = qc" for i
    using Fun(1)[OF nth_mem Fun(2)]
    by (metis (no_types, lifting) length_map nth_concat_split nth_map nth_replicate)
  then show ?case using Fun(1)[OF nth_mem Fun(2)]
    by (auto intro: nth_equalityI)
qed (auto simp flip: fmember.rep_eq dest: reflcl_over_single_ta_epsD)

lemma reflcl_over_single_ta_vars_term:
  "qc |∉| Q ⟹ qc ≠ qf ⟹ qf |∈| ta_der (reflcl_over_single_ta Q ℱ qc qf) u ⟹
   length (vars_term_list u) = n ⟹ (∃ i q. i < n ∧ q |∈| finsert qf Q ∧ vars_term_list u = (replicate n qc)[i := q])"
proof (induct u arbitrary: n)
  case (Var x) then show ?case
    by (intro exI[of _ 0] exI[of _ x]) (auto dest: reflcl_over_single_ta_epsD(1))
next
  case (Fun f ts)
  from Fun(2, 3, 4) obtain qs where rule: "TA_rule f qs qf |∈| semantic_path_rules ℱ qc qf qf"
    "length qs = length ts" "∀ i < length ts. qs ! i |∈| ta_der (reflcl_over_single_ta Q ℱ qc qf) (ts ! i)"
    using semantic_path_rules_rhs reflcl_over_single_ta_epsD
    by (fastforce simp: reflcl_rules_def dest!: reflcl_over_single_ta_rules_split)
  from rule(1, 2) obtain i where states: "i < length ts" "qs = (replicate (length ts) qc)[i := qf]"
    by (auto simp: semantic_path_rules_fmember)
  then have qc: "j < length ts ⟹ j ≠ i ⟹ vars_term_list (ts ! j) = replicate (length (vars_term_list (ts ! j))) qc" for j
    using reflcl_over_single_ta_vars_term_qc[OF Fun(3)] rule
    by force
  from Fun(1)[OF nth_mem, of i] Fun(2, 3) rule states obtain k q where
    qf: "k <  length (vars_term_list (ts ! i))" "q |∈| finsert qf Q"
    "vars_term_list (ts ! i) = (replicate (length (vars_term_list (ts ! i))) qc)[k := q]"
    by (auto simp: nth_list_update split: if_splits)
  let ?l = "sum_list (map length (take i (map vars_term_list ts))) + k"
  show ?case using qc qf rule(2) Fun(5) states(1)
    apply (intro exI[of _ ?l] exI[of _ q])
    apply (auto simp: concat_nth_length nth_list_update elim!: nth_concat_split' intro!: nth_equalityI)
       apply (metis length_replicate nth_list_update_eq nth_list_update_neq nth_replicate)+
    done
qed

lemma refl_ta_reflcl_over_single_ta_mono:
  "q |∈| ta_der (refl_ta ℱ q) t ⟹ q |∈| ta_der (reflcl_over_single_ta Q ℱ q qf) t"
  by (intro ta_der_el_mono[where ?ℬ = "reflcl_over_single_ta Q ℱ q qf"])
    (auto simp: refl_ta_def reflcl_over_single_ta_def)

lemma reflcl_over_single_ta_sound:
  assumes "funas_gctxt C ⊆ fset ℱ" "q |∈| Q"
  shows "qf |∈| ta_der (reflcl_over_single_ta Q ℱ qc qf) (ctxt_of_gctxt C)⟨Var q⟩" using assms(1)
proof (induct C)
  case GHole then show ?case using assms(2)
    by (auto simp add: reflcl_over_single_ta_def)
next
  case (GMore f ss C ts)
  let ?i = "length ss" let ?n = "Suc (length ss + length ts)"
  from GMore have "(f, ?n) |∈| ℱ" by (auto simp flip: fmember.rep_eq)
  then have "f ((replicate ?n qc)[?i := qf]) → qf |∈| rules (reflcl_over_single_ta Q ℱ qc qf)"
    using semantic_path_rules_fmember[of f "(replicate ?n qc)[?i := qf]" qf ℱ qc qf qf]
    using less_add_Suc1
    by (intro reflcl_over_single_ta_rules_semantic_path_rulesI) blast
  moreover from GMore(2) have "i < length ss ⟹ qc |∈| ta_der (reflcl_over_single_ta Q ℱ qc qf) (term_of_gterm (ss ! i))" for i
    by (intro refl_ta_reflcl_over_single_ta_mono refl_ta_sound) (auto simp: SUP_le_iff 𝒯G_funas_gterm_conv)
  moreover from GMore(2) have "i < length ts ⟹ qc |∈| ta_der (reflcl_over_single_ta Q ℱ qc qf) (term_of_gterm (ts ! i))" for i
    by (intro refl_ta_reflcl_over_single_ta_mono refl_ta_sound) (auto simp: SUP_le_iff 𝒯G_funas_gterm_conv)
  moreover from GMore have "qf |∈| ta_der (reflcl_over_single_ta Q ℱ qc qf) (ctxt_of_gctxt C)⟨Var q⟩" by auto
  ultimately show ?case
    by (auto simp: nth_append_Cons simp del: replicate.simps intro!: exI[of _ "(replicate ?n qc)[?i := qf]"] exI[of _ qf])
qed

lemma reflcl_over_single_ta_sig: "ta_sig (reflcl_over_single_ta Q ℱ qc qf) |⊆| ℱ"
  by (intro ta_sig_fsubsetI)
    (auto simp: reflcl_rules_def dest!: semantic_path_rules_fmemberD reflcl_over_single_ta_rules_split)

lemma gen_gctxtcl_lang:
  assumes "qc |∉| 𝒬 𝒜" and "qf |∉| 𝒬 𝒜" and "qc |∉| Q" and "qc ≠ qf"
  shows "gta_lang {|qf|} (gen_ctxt_closure_automaton Q ℱ 𝒜 qc qf) =
    {C⟨s⟩G | C s. funas_gctxt C ⊆ fset ℱ ∧ s ∈ gta_lang Q 𝒜}"
    (is "?Ls = ?Rs")
proof -
  let ?A = "gen_ctxt_closure_automaton Q ℱ 𝒜 qc qf" let ?B = "reflcl_over_single_ta Q ℱ qc qf"
  interpret sq: derivation_split ?A 𝒜 ?B
    using assms unfolding derivation_split_def
    by (auto simp: gen_ctxt_closure_automaton_def reflcl_over_single_ta_def 𝒬_def reflcl_rules_def
        dest!: semantic_path_rules_rhs)
  {fix s assume "s ∈ ?Ls" then obtain u where
      seq: "u |∈| ta_der' 𝒜 (term_of_gterm s)" "Var qf |∈| ta_der'?B u" using sq.ta_der'_split
      by (force simp: ta_der_to_ta_der' elim!: gta_langE)
    have "qc ∉ vars_term u" "qf ∉ vars_term u"
      using subsetD[OF ta_der'_gterm_states[OF seq(1)]] assms(1, 2)
      by (auto simp flip: set_vars_term_list fmember.rep_eq)
    then obtain q where vars: "vars_term_list u = [q]" and fin: "q |∈| Q" unfolding set_vars_term_list[symmetric]
      using reflcl_over_single_ta_vars_term[unfolded ta_der_to_ta_der', OF assms(3, 4) seq(2), of "length (vars_term_list u)"]
      by (metis (no_types, lifting) finsertE in_set_conv_nth length_0_conv length_Suc_conv
          length_replicate lessI less_Suc_eq_0_disj nth_Cons_0 nth_list_update nth_replicate zero_less_Suc)
    have "s ∈ ?Rs" using fin ta_der'_ground_ctxt_structure[OF seq(1) vars]
      using ta_der'_Var_funas[OF seq(2), THEN subset_trans, OF reflcl_over_single_ta_sig[unfolded less_eq_fset.rep_eq]]
      by (auto intro!: exI[of _ "ta_der'_gctxt u"] exI[of _ "ta_der'_source_gctxt_arg u s"])
        (metis Un_iff funas_ctxt_apply funas_ctxt_of_gctxt_conv subset_eq)
  }
  then have ls: "?Ls ⊆ ?Rs" by blast
  {fix t assume "t ∈ ?Rs"
    then obtain C s where gr_fun: "funas_gctxt C ⊆ fset ℱ" and reachA: "s ∈ gta_lang Q 𝒜" and
      const: "t = C⟨s⟩G" by auto
    from reachA obtain q where der_A: "q |∈| Q |∩| 𝒬 𝒜" "q |∈| ta_der 𝒜 (term_of_gterm s)"
      by auto
    have "qf |∈| ta_der ?B (ctxt_of_gctxt C)⟨Var q⟩" using gr_fun der_A(1)
      using reflcl_over_single_ta_sound[OF gr_fun]
      by force
    then have "t ∈ ?Ls" unfolding const
      by (meson der_A(2) finsertI1 gta_langI sq.gctxt_const_to_ta_der)}
  then show ?thesis using ls by blast
qed

lemma gen_gctxt_closure_sound:
  fixes 𝒜 :: "('q, 'f) reg"
  assumes "qc |∉| 𝒬r 𝒜" and "qf |∉| 𝒬r 𝒜" and "qc |∉| fin 𝒜" and "qc ≠ qf"
  shows "ℒ (gen_ctxt_closure_reg ℱ 𝒜 qc qf) = {C⟨s⟩G | C s. funas_gctxt C ⊆ fset ℱ ∧ s ∈ ℒ 𝒜}"
  using gen_gctxtcl_lang[OF assms] unfolding ℒ_def
  by (simp add: gen_ctxt_closure_reg_def)

lemma gen_ctxt_closure_sound:
  fixes 𝒜 :: "('q, 'f) reg"
  assumes "qc |∉| 𝒬r 𝒜" and "qf |∉| 𝒬r 𝒜" and "qc |∉| fin 𝒜" and "qc ≠ qf"
  shows "ℒ (gen_ctxt_closure_reg ℱ 𝒜 qc qf) =
    {(gterm_of_term :: ('f, 'q) term ⇒ 'f gterm) C⟨term_of_gterm s⟩ | C s. ground_ctxt C ∧ funas_ctxt C ⊆ fset ℱ ∧ s ∈ ℒ 𝒜}"
  unfolding gen_gctxt_closure_sound[OF assms]
  by (metis (no_types, opaque_lifting) ctxt_of_gctxt_apply funas_ctxt_of_gctxt_conv gctxt_of_ctxt_inv ground_ctxt_of_gctxt)

lemma gctxt_closure_lang:
  shows "ℒ (ctxt_closure_reg ℱ 𝒜) =
    { C⟨s⟩G | C s. funas_gctxt C ⊆ fset ℱ ∧ s ∈ ℒ 𝒜}"
proof -
  let ?B = "fmap_states_reg Inl (reg_Restr_Qf 𝒜)"
  have ts: "Inr False |∉| 𝒬r ?B" "Inr True |∉| 𝒬r ?B" "Inr False |∉| fin (fmap_states_reg Inl (reg_Restr_Qf 𝒜))"
    by (auto simp: fmap_states_reg_def fmap_states_ta_def' 𝒬_def rule_states_def) 
  from gen_gctxt_closure_sound[OF ts] show ?thesis 
    by (simp add: ctxt_closure_reg_def)
qed

lemma ctxt_closure_lang:
  shows "ℒ (ctxt_closure_reg ℱ 𝒜) =
    {(gterm_of_term :: ('f, 'q + bool) term ⇒ 'f gterm) C⟨term_of_gterm s⟩ |
      C s. ground_ctxt C ∧ funas_ctxt C ⊆ fset ℱ ∧ s ∈ ℒ 𝒜}"
  unfolding gctxt_closure_lang
  by (metis (mono_tags, opaque_lifting) ctxt_of_gctxt_inv funas_gctxt_of_ctxt
      ground_ctxt_of_gctxt ground_gctxt_of_ctxt_apply_gterm term_of_gterm_inv)


subsubsection ‹Correctness of @{const gen_nhole_ctxt_closure_automaton} and @{const nhole_ctxt_closure_reg}›

lemma reflcl_over_nhole_ctxt_ta_vars_term_qc:
  "qc ≠ qf ⟹ qc ≠ qi ⟹ qc |∈| ta_der (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) u ⟹
    vars_term_list u = replicate (length (vars_term_list u)) qc"
proof (induct u)
  case (Fun f ts)
  have "i < length ts ⟹ qc |∈| ta_der (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) (ts ! i)" for i using Fun(2, 3, 4)
    by (auto simp: reflcl_over_nhole_ctxt_ta_def dest!: ftranclD2 reflcl_rules_args semantic_path_rules_rhs)
  then have "i < length (concat (map vars_term_list ts)) ⟹ concat (map vars_term_list ts) ! i = qc" for i
    using Fun(1)[OF nth_mem Fun(2, 3)]
    by (metis (no_types, lifting) length_map map_nth_eq_conv nth_concat_split' nth_replicate)
  then show ?case using Fun(1)[OF nth_mem Fun(2)]
    by (auto intro: nth_equalityI)
qed (auto simp flip: fmember.rep_eq simp: reflcl_over_nhole_ctxt_ta_def dest: ftranclD2)

lemma reflcl_over_nhole_ctxt_ta_vars_term_Var:
  assumes disj: "qc |∉| Q" "qf |∉| Q" "qc ≠ qf" "qi ≠ qf" "qc ≠ qi"
    and reach: "qi |∈| ta_der (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) u"
  shows "(∃ q. q |∈| finsert qi Q ∧  u = Var q)" using assms
  by (cases u) (fastforce simp: reflcl_over_nhole_ctxt_ta_def reflcl_rules_def dest: ftranclD semantic_path_rules_rhs)+

lemma reflcl_over_nhole_ctxt_ta_vars_term:
  assumes disj: "qc |∉| Q" "qf |∉| Q" "qc ≠ qf" "qi ≠ qf" "qc ≠ qi"
    and reach: "qf |∈| ta_der (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) u"
  shows "(∃ i q. i < length (vars_term_list u) ∧ q |∈| {|qi, qf|} |∪| Q ∧ vars_term_list u = (replicate (length (vars_term_list u)) qc)[i := q])"
  using assms
proof (induct u)
  case (Var q) then show ?case
    by (intro exI[of _ 0] exI[of _ q]) (auto simp: reflcl_over_nhole_ctxt_ta_def dest: ftranclD2)
next
  case (Fun f ts)
  from Fun(2 - 7) obtain q qs where rule: "TA_rule f qs qf |∈| semantic_path_rules ℱ qc q qf" "q = qi ∨ q = qf"
    "length qs = length ts" "∀ i < length ts. qs ! i |∈| ta_der (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) (ts ! i)"
    by (auto simp: reflcl_over_nhole_ctxt_ta_def reflcl_rules_def dest: ftranclD2)
  from rule(1- 3) obtain i where states: "i < length ts" "qs = (replicate (length ts) qc)[i := q]"
    by (auto simp: semantic_path_rules_fmember)
  then have qc: "j < length ts ⟹ j ≠ i ⟹ vars_term_list (ts ! j) = replicate (length (vars_term_list (ts ! j))) qc" for j
    using reflcl_over_nhole_ctxt_ta_vars_term_qc[OF Fun(4, 6)] rule
    by force
  from rule states have "q |∈| ta_der (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) (ts ! i)"
    by auto
  from this Fun(1)[OF nth_mem, of i, OF _ Fun(2 - 6)] rule(2) states(1) obtain k q' where
    qf: "k < length (vars_term_list (ts ! i))" "q' |∈| {|qi, qf|} |∪| Q "
    "vars_term_list (ts ! i) = (replicate (length (vars_term_list (ts ! i))) qc)[k :=  q']"
    using reflcl_over_nhole_ctxt_ta_vars_term_Var[OF Fun(2 - 6), of ℱ "ts ! i"]
    by (auto simp: nth_list_update split: if_splits) blast
  let ?l = "sum_list (map length (take i (map vars_term_list ts))) + k"
  show ?case using qc qf rule(3) states(1)
    apply (intro exI[of _ ?l] exI[of _  q'])
    apply (auto 0 0 simp: concat_nth_length nth_list_update elim!: nth_concat_split' intro!: nth_equalityI)
         apply (metis length_replicate nth_list_update_eq nth_list_update_neq nth_replicate)+
    done
qed

lemma reflcl_over_nhole_ctxt_ta_mono:
  "q |∈| ta_der (refl_ta ℱ q) t ⟹ q |∈| ta_der (reflcl_over_nhole_ctxt_ta Q ℱ q qi qf) t"
  by (intro ta_der_el_mono[where ?ℬ = "reflcl_over_nhole_ctxt_ta Q ℱ q qi qf"])
    (auto simp: refl_ta_def reflcl_over_nhole_ctxt_ta_def)


lemma reflcl_over_nhole_ctxt_ta_sound:
  assumes "funas_gctxt C ⊆ fset ℱ" "C ≠ GHole" "q |∈| Q" 
  shows "qf |∈| ta_der (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) (ctxt_of_gctxt C)⟨Var q⟩" using assms(1, 2)
proof (induct C)
  case GHole then show ?case using assms(2)
    by (auto simp add: reflcl_over_single_ta_def)
next
  case (GMore f ss C ts) note IH = this
  let ?i = "length ss" let ?n = "Suc (length ss + length ts)"
  from GMore have funas: "(f, ?n) |∈| ℱ" by (auto simp flip: fmember.rep_eq)
  from GMore(2) have args_ss: "i < length ss ⟹ qc |∈| ta_der (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) (term_of_gterm (ss ! i))" for i
    by (intro reflcl_over_nhole_ctxt_ta_mono refl_ta_sound) (auto simp: SUP_le_iff 𝒯G_funas_gterm_conv)
  from GMore(2) have args_ts: "i < length ts ⟹ qc |∈| ta_der (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) (term_of_gterm (ts ! i))" for i
    by (intro reflcl_over_nhole_ctxt_ta_mono refl_ta_sound) (auto simp: SUP_le_iff 𝒯G_funas_gterm_conv)
  note args = this
  show ?case
  proof (cases C)
    case [simp]: GHole
    from funas have "f ((replicate ?n qc)[?i := qi]) → qf |∈| rules (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf)"
      using semantic_path_rules_fmember[of f "(replicate ?n qc)[?i := qi]" qf ℱ qc qi qf]
      unfolding reflcl_over_nhole_ctxt_ta_def
      by (metis funionCI less_add_Suc1 ta.sel(1))
    moreover have "qi |∈| ta_der (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) (ctxt_of_gctxt C)⟨Var q⟩"
      using assms(3) by (auto simp: reflcl_over_nhole_ctxt_ta_def)
    ultimately show ?thesis using args_ss args_ts
      by (auto simp: nth_append_Cons simp del: replicate.simps intro!: exI[of _ "(replicate ?n qc)[?i := qi]"] exI[of _ qf])
  next
    case (GMore x21 x22 x23 x24)
    then have "qf |∈| ta_der (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) (ctxt_of_gctxt C)⟨Var q⟩"
      using IH(1, 2) by auto
    moreover from funas have "f ((replicate ?n qc)[?i := qf]) → qf |∈| rules (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf)"
      using semantic_path_rules_fmember[of f "(replicate ?n qc)[?i := qf]" qf ℱ qc qf qf]
      unfolding reflcl_over_nhole_ctxt_ta_def
      by (metis funionI2 less_add_Suc1 ta.sel(1))
    ultimately show ?thesis using args_ss args_ts
      by (auto simp: nth_append_Cons simp del: replicate.simps intro!: exI[of _ "(replicate ?n qc)[?i := qf]"] exI[of _ qf])
  qed
qed

lemma reflcl_over_nhole_ctxt_ta_sig: "ta_sig (reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf) |⊆| ℱ"
  by (intro ta_sig_fsubsetI)
    (auto simp: reflcl_over_nhole_ctxt_ta_def reflcl_rules_def dest!: semantic_path_rules_fmemberD)

lemma gen_nhole_gctxt_closure_lang:
  assumes "qc |∉| 𝒬 𝒜" "qi |∉| 𝒬 𝒜" "qf |∉| 𝒬 𝒜"
    and "qc |∉| Q" "qf |∉| Q"
    and "qc ≠ qi" "qc ≠ qf" "qi ≠ qf"
  shows "gta_lang {|qf|} (gen_nhole_ctxt_closure_automaton Q ℱ 𝒜 qc qi qf) =
    {C⟨s⟩G | C s. C ≠ GHole ∧ funas_gctxt C ⊆ fset ℱ ∧ s ∈ gta_lang Q 𝒜}"
    (is "?Ls = ?Rs")
proof -
  let ?A = "gen_nhole_ctxt_closure_automaton Q ℱ 𝒜 qc qi qf" let ?B = "reflcl_over_nhole_ctxt_ta Q ℱ qc qi qf"
  interpret sq: derivation_split ?A 𝒜 ?B
    using assms unfolding derivation_split_def
    by (auto simp: gen_nhole_ctxt_closure_automaton_def reflcl_over_nhole_ctxt_ta_def 𝒬_def reflcl_rules_def
        dest!: semantic_path_rules_rhs)
  {fix s assume "s ∈ ?Ls" then obtain u where
      seq: "u |∈| ta_der' 𝒜 (term_of_gterm s)" "Var qf |∈| ta_der'?B u" using sq.ta_der'_split
      by (force simp: ta_der_to_ta_der' elim!: gta_langE)
    have "qc ∉ vars_term u" "qi ∉ vars_term u" "qf ∉ vars_term u"
      using subsetD[OF ta_der'_gterm_states[OF seq(1)]] assms(1 - 3)
      by (auto simp flip: set_vars_term_list fmember.rep_eq)
    then obtain q where vars: "vars_term_list u = [q]" and fin: "q |∈| Q"
      unfolding set_vars_term_list[symmetric]
      using reflcl_over_nhole_ctxt_ta_vars_term[unfolded ta_der_to_ta_der', OF assms(4, 5, 7 - 8, 6) seq(2)]
      by (metis (no_types, opaque_lifting) finsert_iff funion_commute funion_finsert_right
          length_greater_0_conv lessI list.size(3) list_update_code(2) not0_implies_Suc
          nth_list_update_neq nth_mem nth_replicate replicate_Suc replicate_empty sup_bot.right_neutral)
    from seq(2) have "ta_der'_gctxt u ≠ GHole" using ta_der'_ground_ctxt_structure(1)[OF seq(1) vars]
      using fin assms(4, 5, 8) by (auto simp: reflcl_over_nhole_ctxt_ta_def dest!: ftranclD2)
    then have "s ∈ ?Rs" using fin ta_der'_ground_ctxt_structure[OF seq(1) vars] seq(2)
      using ta_der'_Var_funas[OF seq(2), THEN subset_trans, OF reflcl_over_nhole_ctxt_ta_sig[unfolded less_eq_fset.rep_eq]]
      by (auto intro!: exI[of _ "ta_der'_gctxt u"] exI[of _ "ta_der'_source_gctxt_arg u s"])
        (metis Un_iff funas_ctxt_apply funas_ctxt_of_gctxt_conv in_mono)}
  then have ls: "?Ls ⊆ ?Rs" by blast
  {fix t assume "t ∈ ?Rs"
    then obtain C s where gr_fun: "funas_gctxt C ⊆ fset ℱ" "C ≠ GHole" and reachA: "s ∈ gta_lang Q 𝒜" and
      const: "t = C⟨s⟩G" by auto
    from reachA obtain q where der_A: "q |∈| Q |∩| 𝒬 𝒜" "q |∈| ta_der 𝒜 (term_of_gterm s)"
      by auto
    have "qf |∈| ta_der ?B (ctxt_of_gctxt C)⟨Var q⟩" using gr_fun der_A(1)
      using reflcl_over_nhole_ctxt_ta_sound[OF gr_fun]
      by force
    then have "t ∈ ?Ls" unfolding const
      by (meson der_A(2) finsertI1 gta_langI sq.gctxt_const_to_ta_der)}
  then show ?thesis using ls by blast
qed

lemma gen_nhole_gctxt_closure_sound:
  assumes "qc |∉| 𝒬r 𝒜" "qi |∉| 𝒬r 𝒜" "qf |∉| 𝒬r 𝒜"
    and "qc |∉| (fin 𝒜)" "qf |∉| (fin 𝒜)"
    and "qc ≠ qi" "qc ≠ qf" "qi ≠ qf"
  shows "ℒ (gen_nhole_ctxt_closure_reg ℱ 𝒜 qc qi qf) =
    { C⟨s⟩G | C s. C ≠ GHole ∧ funas_gctxt C ⊆ fset ℱ ∧ s ∈ ℒ 𝒜}"
  using gen_nhole_gctxt_closure_lang[OF assms] unfolding ℒ_def
  by (auto simp: gen_nhole_ctxt_closure_reg_def)


lemma nhole_ctxtcl_lang:
  "ℒ (nhole_ctxt_closure_reg ℱ 𝒜) =
    { C⟨s⟩G | C s. C ≠ GHole ∧ funas_gctxt C ⊆ fset ℱ ∧ s ∈ ℒ 𝒜}"
proof -
  let ?B = "fmap_states_reg (Inl :: 'b ⇒ 'b + cl_states) (reg_Restr_Qf 𝒜)"
  have ts: "Inr cl_state |∉| 𝒬r ?B" "Inr tr_state |∉| 𝒬r ?B" "Inr fin_state |∉| 𝒬r ?B"
    by (auto simp: fmap_states_reg_def)
  then have "Inr cl_state |∉| fin (fmap_states_reg Inl (reg_Restr_Qf 𝒜))"
    "Inr fin_state |∉| fin (fmap_states_reg Inl (reg_Restr_Qf 𝒜))"
    using finj_Inl_Inr(1) fmap_states_reg_Restr_Qf_fin by blast+
  from gen_nhole_gctxt_closure_sound[OF ts this] show ?thesis
    by (simp add: nhole_ctxt_closure_reg_def Let_def)
qed


subsubsection ‹Correctness of @{const gen_nhole_mctxt_closure_automaton}›

lemmas reflcl_over_nhole_mctxt_ta_simp = reflcl_over_nhole_mctxt_ta_def reflcl_over_nhole_ctxt_ta_def

lemma reflcl_rules_rhsD:
  "f ps → q |∈| reflcl_rules ℱ qc ⟹ q = qc"
  by (auto simp: reflcl_rules_def)

lemma reflcl_over_nhole_mctxt_ta_vars_term:
  assumes "q |∈| ta_der (reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf) t"
   and "qc |∉| Q" "q ≠ qc" "qf ≠ qc" "qi ≠ qc"
  shows "vars_term t ≠ {}" using assms
proof (induction t arbitrary: q)
  case (Fun f ts)
  let ?A = "reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf"
  from Fun(2) obtain p ps where rule: "TA_rule f ps p |∈| rules ?A"
    "length ps = length ts" "∀ i < length ts. ps ! i |∈| ta_der ?A (ts ! i)"
    "p = q ∨ (p, q) |∈| (eps ?A)|+|"
    by force
  from rule(1, 4) Fun(3-) have "p ≠ qc"
    by (auto simp: reflcl_over_nhole_mctxt_ta_simp dest: ftranclD)
  then have "∃ i < length ts. ps ! i ≠ qc" using rule(1, 2) Fun(4-)
    using semantic_path_rules_fmemberD
    by (force simp: reflcl_over_nhole_mctxt_ta_simp dest: reflcl_rules_rhsD)
  then show ?case using Fun(1)[OF nth_mem _ Fun(3) _ Fun(5, 6)] rule(2, 3)
    by fastforce
qed auto

lemma reflcl_over_nhole_mctxt_ta_Fun:
  assumes "qf |∈| ta_der (reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf) t" "t ≠ Var qf"
    and  "qf ≠ qc" "qf ≠ qi"
  shows "is_Fun t" using assms
  by (cases t) (auto simp: reflcl_over_nhole_mctxt_ta_simp dest: ftranclD2)

lemma rule_states_reflcl_rulesD:
  "p |∈| rule_states (reflcl_rules ℱ q) ⟹ p = q"
  by (auto simp: reflcl_rules_def rule_states_def fset_of_list_elem)

lemma rule_states_semantic_path_rulesD:
  "p |∈| rule_states (semantic_path_rules ℱ qc qi qf) ⟹ p = qc ∨ p = qi ∨ p = qf"
  by (auto simp: rule_states_def dest!: semantic_path_rules_fmemberD)
    (metis in_fset_conv_nth length_list_update length_replicate nth_list_update nth_replicate)

lemma 𝒬_reflcl_over_nhole_mctxt_ta:
  "𝒬 (reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf) |⊆| Q |∪| {|qc, qi, qf|}"
  by (auto 0 0 simp: eps_states_def reflcl_over_nhole_mctxt_ta_simp 𝒬_def
      dest!: rule_states_reflcl_rulesD rule_states_semantic_path_rulesD)

lemma reflcl_over_nhole_mctxt_ta_vars_term_subset_eq:
  assumes "q |∈| ta_der (reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf) t" "q = qf ∨ q = qi"
  shows "vars_term t ⊆ {qc, qi, qf} ∪ fset Q"
  using fresh_states_ta_der'_pres[OF _ _ assms(1)[unfolded ta_der_to_ta_der']] assms(2)
  using fsubsetD[OF 𝒬_reflcl_over_nhole_mctxt_ta[of Q ℱ qc qi qf]]
  by auto (meson notin_fset)+ 

lemma sig_reflcl_over_nhole_mctxt_ta [simp]:
  "ta_sig (reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf) = ℱ"
  by (force simp: reflcl_over_nhole_mctxt_ta_simp reflcl_rules_def
      dest!: semantic_path_rules_fmemberD intro!: ta_sig_fsubsetI)

lemma reflcl_over_nhole_mctxt_ta_aux_sound:
  assumes "funas_term t ⊆ fset ℱ" "vars_term t ⊆ fset Q"
  shows "qc |∈| ta_der (reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf) t" using assms
proof (induct t)
  case (Var x)
  then show ?case
    by (auto simp: reflcl_over_nhole_mctxt_ta_simp fimage_iff simp flip: fmember.rep_eq)
     (meson finsertI1 finsertI2 fr_into_trancl ftrancl_into_trancl rev_fimage_eqI)
next
  case (Fun f ts)
  from Fun(2) have "TA_rule f (replicate (length ts) qc) qc |∈| rules (reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf)"
    by (auto simp: reflcl_over_nhole_mctxt_ta_simp reflcl_rules_def fimage_iff fBall_def
             simp flip: fmember.rep_eq split: prod.splits)
  then show ?case using Fun(1)[OF nth_mem] Fun(2-)
    by (auto simp: SUP_le_iff) (metis length_replicate nth_replicate)
qed

lemma reflcl_over_nhole_mctxt_ta_sound:
  assumes "funas_term t ⊆ fset ℱ" "vars_term t ⊆ fset Q" "vars_term t ≠ {}"
  shows "(is_Var t ⟶ qi |∈| ta_der (reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf) t) ∧
    (is_Fun t ⟶ qf |∈| ta_der (reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf) t)" using assms
proof (induct t)
  case (Fun f ts)
  let ?A = "reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf"
  from Fun(4) obtain i where vars: "i < length ts" "vars_term (ts ! i) ≠ {}"
    by (metis SUP_le_iff in_set_conv_nth subset_empty term.set(4))
  consider (v) "is_Var (ts ! i)" | (f) "is_Fun (ts ! i)" by blast
  then show ?case
  proof cases
    case v
    from v Fun(1)[OF nth_mem[OF vars(1)]] have "qi |∈| ta_der ?A (ts ! i)"
      using vars Fun(2-) by (auto simp: SUP_le_iff)
    moreover have "f (replicate (length ts) qc)[i := qi] → qf |∈| rules ?A"
      using Fun(2) vars(1)
      by (auto simp: reflcl_over_nhole_mctxt_ta_simp semantic_path_rules_fmember simp flip: fmember.rep_eq)
    moreover have "j < length ts ⟹ qc |∈| ta_der ?A (ts ! j)" for j using Fun(2-)
      by (intro reflcl_over_nhole_mctxt_ta_aux_sound) (auto simp: SUP_le_iff)
    ultimately show ?thesis using vars
      by auto (metis length_list_update length_replicate nth_list_update nth_replicate)
  next
    case f
    from f Fun(1)[OF nth_mem[OF vars(1)]] have "qf |∈| ta_der ?A (ts ! i)"
      using vars Fun(2-) by (auto simp: SUP_le_iff)
    moreover have "f (replicate (length ts) qc)[i := qf] → qf |∈| rules ?A"
      using Fun(2) vars(1)
      by (auto simp: reflcl_over_nhole_mctxt_ta_simp semantic_path_rules_fmember simp flip: fmember.rep_eq)
    moreover have "j < length ts ⟹ qc |∈| ta_der ?A (ts ! j)" for j using Fun(2-)
      by (intro reflcl_over_nhole_mctxt_ta_aux_sound) (auto simp: SUP_le_iff)
    ultimately show ?thesis using vars
      by auto (metis length_list_update length_replicate nth_list_update nth_replicate) 
  qed
qed (auto simp: reflcl_over_nhole_mctxt_ta_simp simp flip: fmember.rep_eq dest!: ftranclD2)


lemma gen_nhole_gmctxt_closure_lang:
  assumes "qc |∉| 𝒬 𝒜" and "qi |∉| 𝒬 𝒜" "qf |∉| 𝒬 𝒜"
    and "qc |∉| Q" "qf ≠ qc" "qf ≠ qi" "qi ≠ qc"
  shows "gta_lang {|qf|} (gen_nhole_mctxt_closure_automaton Q ℱ 𝒜 qc qi qf) =
    { fill_gholes C ss |
      C ss. 0 < num_gholes C ∧ num_gholes C = length ss ∧ C ≠ GMHole ∧
      funas_gmctxt C ⊆ fset ℱ ∧ (∀ i < length ss. ss ! i ∈ gta_lang Q 𝒜)}"
    (is "?Ls = ?Rs")
proof -
  let ?A = "gen_nhole_mctxt_closure_automaton Q ℱ 𝒜 qc qi qf" let ?B = "reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf"
  interpret sq: derivation_split "?A" "𝒜" "?B"
    using assms unfolding derivation_split_def
    by (auto simp: gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def
        reflcl_over_nhole_ctxt_ta_def 𝒬_def reflcl_rules_def dest!: semantic_path_rules_rhs)
  {fix s assume "s ∈ ?Ls" then obtain u where
      seq: "u |∈| ta_der' 𝒜 (term_of_gterm s)" "Var qf |∈| ta_der'?B u"
      by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
    note der = seq(2)[unfolded ta_der_to_ta_der'[symmetric]]
    have "vars_term u ⊆ fset Q" "vars_term u ≠ {}"
      using ta_der'_gterm_states[OF seq(1)] assms(1 - 3)
      using reflcl_over_nhole_mctxt_ta_vars_term[OF der assms(4) assms(5) assms(5) assms(7)]
      using reflcl_over_nhole_mctxt_ta_vars_term_subset_eq[OF der]
      by (metis Un_insert_left insert_is_Un notin_fset subset_iff subset_insert)+
    then have vars: "¬ ground u" "i < length (ta_der'_target_args u) ⟹ ta_der'_target_args u ! i |∈| Q" for i
      by (auto simp: ta_der'_target_args_def split_vars_vars_term_list
          fmember.rep_eq set_list_subset_nth_conv simp flip: set_vars_term_list)
    have hole: "ta_der'_target_mctxt u ≠ MHole" using vars assms(3-)
      using reflcl_over_nhole_mctxt_ta_Fun[OF der]
      using ta_der'_mctxt_structure(1, 3)[OF seq(1)]
      by auto (metis fill_holes_MHole gterm_ta_der_states length_map lessI map_nth_eq_conv seq(1) ta_der_to_ta_der' term.disc(1))
    let ?w = "λ i. ta_der'_source_args u (term_of_gterm s) ! i"
    have "s ∈ ?Rs" using seq(1) ta_der'_Var_funas[OF seq(2)]
      using ground_ta_der_statesD[of "?w i" "ta_der'_target_args u ! i" 𝒜 for i] assms vars
      using ta_der'_ground_mctxt_structure[OF seq(1)] hole
      by (force simp: ground_gmctxt_of_mctxt_fill_holes' ta_der'_source_args_term_of_gterm
          intro!: exI[of _ "gmctxt_of_mctxt (ta_der'_target_mctxt u)"]
          exI[of _ "map gterm_of_term (ta_der'_source_args u (term_of_gterm s))"]
          gta_langI[of "ta_der'_target_args u ! i" Q 𝒜
            "gterm_of_term (?w i)" for i])}
  then have ls: "?Ls ⊆ ?Rs" by blast
  {fix t assume "t ∈ ?Rs"
    then obtain C ss where len: "0 < num_gholes C" "num_gholes C = length ss" "C ≠ GMHole" and
      gr_fun: "funas_gmctxt C ⊆ fset ℱ" and
      reachA: "∀ i < length ss. ss ! i ∈ gta_lang Q 𝒜" and
      const: "t = fill_gholes C ss" by auto
    from reachA obtain qs where states: "length ss = length qs" "∀ i < length qs. qs ! i |∈| Q |∩| 𝒬 𝒜"
      "∀ i < length qs. qs ! i |∈| ta_der 𝒜 ((map term_of_gterm ss) ! i)"
      using Ex_list_of_length_P[of "length ss" "λ q i. q |∈| ta_der 𝒜 (term_of_gterm (ss ! i)) ∧ q |∈| Q"]
      by (metis (full_types) finterI gta_langE gterm_ta_der_states length_map map_nth_eq_conv)
    have [simp]: "is_Fun (fill_holes (mctxt_of_gmctxt C) (map Var qs)) ⟷ True"
      "is_Var (fill_holes (mctxt_of_gmctxt C) (map Var qs)) ⟷ False"
      using len(3) by (cases C, auto)+
    have "qf |∈| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
      using reachA len gr_fun states
      using reflcl_over_nhole_mctxt_ta_sound[of "fill_holes (mctxt_of_gmctxt C) (map Var qs)"]
      by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs qf])
        (auto simp: funas_mctxt_of_gmctxt_conv  fmember.rep_eq set_list_subset_eq_nth_conv
          simp flip: fmember.rep_eq dest!: in_set_idx)
    then have "t ∈ ?Ls" unfolding const
      by (simp add: fill_holes_mctxt_of_gmctxt_to_fill_gholes gta_langI len)}
  then show ?thesis using ls by blast
qed

lemma nhole_gmctxt_closure_lang:
  "ℒ (nhole_mctxt_closure_reg ℱ 𝒜) =
    { fill_gholes C ss | C ss. num_gholes C = length ss ∧ 0 < num_gholes C ∧ C ≠ GMHole ∧
      funas_gmctxt C ⊆ fset ℱ ∧ (∀ i < length ss. ss ! i ∈ ℒ 𝒜)}"
  (is "?Ls = ?Rs")
proof -
  let ?B = "fmap_states_reg (Inl :: 'b ⇒ 'b + cl_states) (reg_Restr_Qf 𝒜)"
  have ts: "Inr cl_state |∉| 𝒬r ?B" "Inr tr_state |∉| 𝒬r ?B" "Inr fin_state |∉| 𝒬r ?B"
    "Inr cl_state |∉| fin ?B"
    by (auto simp: fmap_states_reg_def)
  have [simp]: "gta_lang (fin (fmap_states_reg Inl (reg_Restr_Qf 𝒜))) (ta (fmap_states_reg Inl (reg_Restr_Qf 𝒜)))
    = gta_lang (fin 𝒜) (ta 𝒜)"
    by (metis ℒ_def ℒ_fmap_states_reg_Inl_Inr(1) reg_Rest_fin_states) 
  from gen_nhole_gmctxt_closure_lang[OF ts] show ?thesis 
    by (auto simp add: nhole_mctxt_closure_reg_def gen_nhole_mctxt_closure_reg_def Let_def ℒ_def)
qed

subsubsection ‹Correctness of @{const gen_mctxt_closure_reg} and @{const mctxt_closure_reg}›

lemma gen_gmctxt_closure_lang:
  assumes "qc |∉| 𝒬 𝒜" and "qi |∉| 𝒬 𝒜" "qf |∉| 𝒬 𝒜"
    and disj: "qc |∉| Q" "qf ≠ qc" "qf ≠ qi" "qi ≠ qc"
  shows "gta_lang {|qf, qi|} (gen_nhole_mctxt_closure_automaton Q ℱ 𝒜 qc qi qf) =
    { fill_gholes C ss |
      C ss. 0 < num_gholes C ∧ num_gholes C = length ss ∧
      funas_gmctxt C ⊆ fset ℱ ∧ (∀ i < length ss. ss ! i ∈ gta_lang Q 𝒜)}"
    (is "?Ls = ?Rs")
proof -
  let ?A = "gen_nhole_mctxt_closure_automaton Q ℱ 𝒜 qc qi qf" let ?B = "reflcl_over_nhole_mctxt_ta Q ℱ qc qi qf"
  interpret sq: derivation_split "?A" "𝒜" "?B"
    using assms unfolding derivation_split_def
    by (auto simp: gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def
        reflcl_over_nhole_ctxt_ta_def 𝒬_def reflcl_rules_def dest!: semantic_path_rules_rhs)
  {fix s assume "s ∈ ?Ls" then obtain u q where
      seq: "u |∈| ta_der' 𝒜 (term_of_gterm s)" "Var q |∈| ta_der'?B u" "q = qf ∨ q = qi"
      by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
    have "vars_term u ⊆ fset Q" "vars_term u ≠ {}"
      using ta_der'_gterm_states[OF seq(1)] assms seq(3)
      using reflcl_over_nhole_mctxt_ta_vars_term[OF seq(2)[unfolded ta_der_to_ta_der'[symmetric]] disj(1) _ disj(2, 4)]
      using reflcl_over_nhole_mctxt_ta_vars_term_subset_eq[OF seq(2)[unfolded ta_der_to_ta_der'[symmetric]] seq(3)]
      by (metis Un_insert_left notin_fset subsetD subset_insert sup_bot_left)+
    then have vars: "¬ ground u" "i < length (ta_der'_target_args u) ⟹ ta_der'_target_args u ! i |∈| Q" for i
      by (auto simp: ta_der'_target_args_def split_vars_vars_term_list
          fmember.rep_eq set_list_subset_nth_conv simp flip: set_vars_term_list)
    let ?w = "λ i. ta_der'_source_args u (term_of_gterm s) ! i"
    have "s ∈ ?Rs" using seq(1) ta_der'_Var_funas[OF seq(2)]
      using ground_ta_der_statesD[of "?w i" "ta_der'_target_args u ! i" 𝒜 for i] assms vars
      using ta_der'_ground_mctxt_structure[OF seq(1)]
      by (force simp: ground_gmctxt_of_mctxt_fill_holes' ta_der'_source_args_term_of_gterm
          intro!: exI[of _ "gmctxt_of_mctxt (ta_der'_target_mctxt u)"]
          exI[of _ "map gterm_of_term (ta_der'_source_args u (term_of_gterm s))"]
          gta_langI[of "ta_der'_target_args u ! i" Q 𝒜
            "gterm_of_term (?w i)" for i])}
  then have "?Ls ⊆ ?Rs" by blast
  moreover
  {fix t assume "t ∈ ?Rs"
    then obtain C ss where len: "0 < num_gholes C" "num_gholes C = length ss" and
      gr_fun: "funas_gmctxt C ⊆ fset ℱ" and
      reachA: "∀ i < length ss. ss ! i ∈ gta_lang Q 𝒜" and
      const: "t = fill_gholes C ss" by auto
    from const have const': "term_of_gterm t = fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss)"
      by (simp add: fill_holes_mctxt_of_gmctxt_to_fill_gholes len(2))
    from reachA obtain qs where states: "length ss = length qs" "∀ i < length qs. qs ! i |∈| Q |∩| 𝒬 𝒜"
      "∀ i < length qs. qs ! i |∈| ta_der 𝒜 ((map term_of_gterm ss) ! i)"
      using Ex_list_of_length_P[of "length ss" "λ q i. q |∈| ta_der 𝒜 (term_of_gterm (ss ! i)) ∧ q |∈| Q"]
      by (metis (full_types) finterI gta_langE gterm_ta_der_states length_map map_nth_eq_conv)
    have "C = GMHole ⟹ is_Var (fill_holes (mctxt_of_gmctxt C) (map Var qs)) = True" using len states(1)
      by (metis fill_holes_MHole length_map mctxt_of_gmctxt.simps(1) nth_map num_gholes.simps(1) term.disc(1))
    then have hole: "C = GMHole ⟹ qi |∈| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
      using reachA len gr_fun states len
      using reflcl_over_nhole_mctxt_ta_sound[of "fill_holes (mctxt_of_gmctxt C) (map Var qs)"]
      by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs qi])
         (auto simp: funas_mctxt_of_gmctxt_conv  fmember.rep_eq set_list_subset_eq_nth_conv
          simp flip: fmember.rep_eq dest!: in_set_idx)
    have "C ≠ GMHole ⟹ is_Fun (fill_holes (mctxt_of_gmctxt C) (map Var qs)) = True"
      by (cases C) auto
    then have "C ≠ GMHole ⟹ qf |∈| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
      using reachA len gr_fun states
      using reflcl_over_nhole_mctxt_ta_sound[of "fill_holes (mctxt_of_gmctxt C) (map Var qs)"]
      by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs qf])
         (auto simp: funas_mctxt_of_gmctxt_conv  fmember.rep_eq set_list_subset_eq_nth_conv
          simp flip: fmember.rep_eq dest!: in_set_idx)
    then have "t ∈ ?Ls" using hole const' unfolding gta_lang_def gta_der_def
      by (metis (mono_tags, lifting) fempty_iff finsert_iff finterI mem_Collect_eq)}
  ultimately show ?thesis
    by (meson subsetI subset_antisym) 
qed


lemma gmctxt_closure_lang:
  "ℒ (mctxt_closure_reg ℱ 𝒜) =
    { fill_gholes C ss | C ss. num_gholes C = length ss ∧ 0 < num_gholes C ∧
      funas_gmctxt C ⊆ fset ℱ ∧ (∀ i < length ss. ss ! i ∈ ℒ 𝒜)}"
  (is "?Ls = ?Rs")
proof -
  let ?B = "fmap_states_reg (Inl :: 'b ⇒ 'b + cl_states) (reg_Restr_Qf 𝒜)"
  have ts: "Inr cl_state |∉| 𝒬r ?B" "Inr tr_state |∉| 𝒬r ?B" "Inr fin_state |∉| 𝒬r ?B"
    "Inr cl_state |∉| fin ?B"
    by (auto simp: fmap_states_reg_def)
  have [simp]: "gta_lang (fin (fmap_states_reg Inl (reg_Restr_Qf 𝒜))) (ta (fmap_states_reg Inl (reg_Restr_Qf 𝒜)))
    = gta_lang (fin 𝒜) (ta 𝒜)"
    by (metis ℒ_def ℒ_fmap_states_reg_Inl_Inr(1) reg_Rest_fin_states) 
  from gen_gmctxt_closure_lang[OF ts] show ?thesis
    by (auto simp add: mctxt_closure_reg_def gen_mctxt_closure_reg_def Let_def ℒ_def)
qed


subsubsection ‹Correctness of @{const nhole_mctxt_reflcl_reg}›

lemma nhole_mctxt_reflcl_lang:
  "ℒ (nhole_mctxt_reflcl_reg ℱ 𝒜) = ℒ (nhole_mctxt_closure_reg ℱ 𝒜) ∪ 𝒯G (fset ℱ)"
proof -
  let ?refl = "Reg {|fin_clstate|} (refl_ta ℱ (fin_clstate))"
  {fix t assume "t ∈ ℒ ?refl" then have "t ∈ 𝒯G (fset ℱ)"
      using reg_funas by fastforce}
  moreover
  {fix t assume "t ∈ 𝒯G (fset ℱ)" then have "t ∈ ℒ ?refl"
      by (simp add: ℒ_def gta_langI refl_ta_sound)}
  ultimately have *: "ℒ ?refl = 𝒯G (fset ℱ)"
    by blast
  show ?thesis unfolding nhole_mctxt_reflcl_reg_def ℒ_union * by simp
qed
declare ta_union_def [simp del]
end
>

Theory Type_Instances_Impl

theory Type_Instances_Impl
  imports Bot_Terms
    TA_Clousure_Const
    Regular_Tree_Relations.Tree_Automata_Class_Instances_Impl
begin


section ‹Type class instantiations for the implementation›

derive linorder sum
derive linorder bot_term
derive linorder cl_states

derive compare bot_term
derive compare cl_states

derive (eq) ceq bot_term mctxt cl_states

derive (compare) ccompare bot_term cl_states

derive (rbt) set_impl bot_term cl_states

derive (no) cenum bot_term

instantiation cl_states :: cenum
begin
abbreviation "cl_all_list ≡ [cl_state, tr_state, fin_state, fin_clstate]"
definition cEnum_cl_states :: "(cl_states list × ((cl_states ⇒ bool) ⇒ bool) × ((cl_states ⇒ bool) ⇒ bool)) option"
  where "cEnum_cl_states = Some (cl_all_list, (λ P. list_all P cl_all_list),  (λ P. list_ex P cl_all_list))"
instance
  apply intro_classes apply (auto simp: cEnum_cl_states_def elim!: cl_states.induct)
  using cl_states.exhaust apply blast
  by (metis cl_states.exhaust)
end

lemma infinite_bot_term_UNIV[simp, intro]: "infinite (UNIV :: 'f bot_term set)"
proof -
  fix f :: 'f
  let ?inj = "λn. BFun f (replicate n Bot)"
  have "inj ?inj" unfolding inj_on_def by auto
  from infinite_super[OF _ range_inj_infinite[OF this]]
  show ?thesis by blast
qed

lemma finite_cl_states: "(UNIV :: cl_states set) = {cl_state, tr_state, fin_state, fin_clstate}"
  using cl_states.exhaust
  by auto

instantiation cl_states :: card_UNIV begin
definition "finite_UNIV = Phantom(cl_states) True"
definition "card_UNIV = Phantom(cl_states) 4"
instance
  by intro_classes (simp_all add: card_UNIV_cl_states_def finite_UNIV_cl_states_def finite_cl_states)
end

instantiation bot_term :: (type) finite_UNIV
begin
definition "finite_UNIV = Phantom('a bot_term) False"
instance
  by (intro_classes, unfold finite_UNIV_bot_term_def, simp)
end


instantiation bot_term :: (compare) cproper_interval
begin
definition "cproper_interval = (λ ( _ :: 'a bot_term option) _ . False)"
instance by (intro_classes, auto)
end

instantiation cl_states :: cproper_interval
begin

(* cl_all_list *)
definition cproper_interval_cl_states :: "cl_states option ⇒ cl_states option ⇒ bool"
  where "cproper_interval_cl_states x y =
   (case ID CCOMPARE(cl_states) of Some f ⇒
   (case x of None ⇒
     (case y of None ⇒ True | Some c ⇒ list_ex (λ x. (lt_of_comp f) x c) cl_all_list)
   | Some c ⇒
     (case y of None ⇒ list_ex (λ x. (lt_of_comp f) c x) cl_all_list
      | Some d ⇒ (filter (λ x. (lt_of_comp f) x d ∧ (lt_of_comp f) c x) cl_all_list) ≠ [])))"

instance
proof (intro_classes)
  assume ass: "(ID ccompare :: (cl_states ⇒ cl_states ⇒ order) option) ≠ None"
  from ass obtain f where comp: "(ID ccompare :: (cl_states ⇒ cl_states ⇒ order) option) = Some f" by auto
  let ?g = "cproper_interval :: cl_states option ⇒ cl_states option ⇒ bool"
  have [simp]: "x < y ⟷ lt_of_comp f x y" for x y
    by (metis ID_Some ccompare_cl_states_def comp compare_cl_states_def less_cl_states_def option.sel)
  {fix c d x assume "lt_of_comp f x d" "lt_of_comp f c x"
    then have "c < x" "x < d" by simp_all}
  moreover
  {fix c d assume "∃ z. (c ::cl_states) < z ∧ z < d"
    then obtain z where w: "c < z ∧ z < d" by blast
    then have "z ∈ set cl_all_list" by (cases z) auto
    moreover have "lt_of_comp f z d ∧ lt_of_comp f c z" using w comp
      by auto
    ultimately have "filter (λx. lt_of_comp f x d ∧ lt_of_comp f c x) cl_all_list ≠ []" using w
      by auto}
  ultimately have "filter (λx. lt_of_comp f x d ∧ lt_of_comp f c x) cl_all_list ≠ [] ⟷ (∃ z. c < z ∧ z < d)" for d c using comp
    unfolding filter_empty_conv by simp blast
  then have "?g (Some x) (Some y) = (∃ z. x < z ∧ z < y)" for x y
    by (simp add: comp cproper_interval_cl_states_def)
  moreover have "?g None None = True" by (simp add: comp cproper_interval_cl_states_def)
  moreover have "?g None (Some y) = (∃z. z < y)" for y using comp
    by (auto simp add: cproper_interval_cl_states_def ccompare_cl_states_def) (metis cl_states.exhaust)+
  moreover have "?g (Some y) None = (∃z. y < z)" for y using comp
    by (auto simp add: cproper_interval_cl_states_def) (metis cl_states.exhaust)+
  ultimately show "class.proper_interval cless ?g"
    unfolding class.proper_interval_def comp
    by simp
qed
end

derive (rbt) mapping_impl cl_states
derive (rbt) mapping_impl bot_term

end
div class="head">

Theory NF_Impl

theory NF_Impl
  imports NF
    Type_Instances_Impl
begin

subsubsection ‹Implementation of normal form construction›
(* Implementation *)
fun supteq_list :: "('f, 'v) Term.term ⇒ ('f, 'v) Term.term list"
where
  "supteq_list (Var x) = [Var x]" |
  "supteq_list (Fun f ts) = Fun f ts # concat (map supteq_list ts)"

fun supt_list :: "('f, 'v) Term.term ⇒ ('f, 'v) Term.term list"
where
  "supt_list (Var x) = []" |
  "supt_list (Fun f ts) = concat (map supteq_list ts)"

lemma supteq_list [simp]:
  "set (supteq_list t) = {s. t ⊵ s}"
proof (rule set_eqI, simp)
  fix s
  show "s ∈ set(supteq_list t) = (t ⊵ s)"
  proof (induct t, simp add: supteq_var_imp_eq)
    case (Fun f ss)
    show ?case
    proof (cases "Fun f ss = s", (auto)[1])
      case False
      show ?thesis
      proof
        assume "Fun f ss ⊵ s"
        with False have sup: "Fun f ss ⊳ s" using supteq_supt_conv by auto
        obtain C where "C ≠ □" and "Fun f ss = C⟨s⟩" using sup by auto
        then obtain b D a where "Fun f ss = Fun f (b @ D⟨s⟩ # a)" by (cases C, auto)
        then have D: "D⟨s⟩ ∈ set ss" by auto
        with Fun[OF D] ctxt_imp_supteq[of D s] obtain t where "t ∈ set ss" and "s ∈ set (supteq_list t)" by auto
        then show "s ∈ set (supteq_list (Fun f ss))" by auto
      next
        assume "s ∈ set (supteq_list (Fun f ss))"
        with False obtain t where t: "t ∈ set ss" and "s ∈ set (supteq_list t)" by auto
        with Fun[OF t] have "t ⊵ s" by auto
        with t show "Fun f ss ⊵ s" by auto
      qed
    qed
  qed
qed

lemma supt_list_sound [simp]:
  "set (supt_list t) = {s. t ⊳ s}"
  by (cases t) auto

fun mergeP_impl where
  "mergeP_impl Bot t = True"
| "mergeP_impl t Bot = True"
| "mergeP_impl (BFun f ss) (BFun g ts) =
  (if f = g ∧ length ss = length ts then list_all (λ (x, y). mergeP_impl x y) (zip ss ts)  else False)"

lemma [simp]: "mergeP_impl s Bot = True" by (cases s) auto 

lemma [simp]: "mergeP_impl s t ⟷ (s, t) ∈ mergeP" (is "?LS = ?RS")
proof
  show "?LS ⟹ ?RS"
    by (induct rule: mergeP_impl.induct, auto split: if_splits intro!: step)
      (smt length_zip list_all_length mergeP.step min_less_iff_conj nth_mem nth_zip old.prod.case)
next
  show "?RS ⟹ ?LS" by (induct rule: mergeP.induct, auto simp add: list_all_length)
qed

fun bless_eq_impl where
  "bless_eq_impl Bot t = True"
| "bless_eq_impl (BFun f ss) (BFun g ts) =
  (if f = g ∧ length ss = length ts then list_all (λ (x, y). bless_eq_impl x y) (zip ss ts) else False)"
| "bless_eq_impl _ _ = False"


lemma [simp]: "bless_eq_impl s t ⟷ (s, t) ∈ bless_eq" (is "?RS = ?LS")
proof
  show "?LS ⟹ ?RS" by (induct rule: bless_eq.induct, auto simp add: list_all_length)
next
  show "?RS ⟹ ?LS"
    by (induct rule: bless_eq_impl.induct, auto split: if_splits intro!: bless_eq.step)
      (metis (full_types) length_zip list_all_length min_less_iff_conj nth_mem nth_zip old.prod.case)
qed

definition "psubt_bot_impl R ≡ remdups (map term_to_bot_term (concat (map supt_list R)))"
lemma psubt_bot_impl[simp]: "set (psubt_bot_impl R) = psubt_lhs_bot (set R)"
  by (induct R, auto simp: psubt_bot_impl_def)

definition "states_impl R = List.insert Bot (map the (removeAll None
    (closure_impl (lift_f_total mergeP_impl (↑)) (map Some (psubt_bot_impl R)))))"

lemma states_impl [simp]: "set (states_impl R) = states (set R)"
proof -
  have [simp]: "lift_f_total mergeP_impl (↑) = lift_f_total (λ x y. mergeP_impl x y) (↑)" by blast
  show ?thesis unfolding states_impl_def states_def
    using lift_total.cl.closure_impl
    by (simp add: lift_total.cl.pred_closure_lift_closure) 
qed

abbreviation check_intance_lhs where
  "check_intance_lhs qs f R ≡ list_all (λ u. ¬ bless_eq_impl u (BFun f qs)) R"

definition min_elem where
  "min_elem s ss = (let ts = filter (λ x. bless_eq_impl x s) ss in
      foldr (↑) ts Bot)"

lemma bound_impl [simp, code]:
  "bound_max s (set ss) = min_elem s ss"
proof -
  have [simp]: "{y. lift_total.lifted_less_eq y (Some s) ∧ y ∈ Some ` set ss} = Some ` {x ∈ set ss. x ≤b s}"
    by auto
  then show ?thesis
    using lift_total.supremum_impl[of "filter (λ x. bless_eq_impl x s) ss"]
    using lift_total.supremum_smaller_exists_unique[of "set ss" s]
    by (auto simp: min_elem_def Let_def lift_total.lift_ord.smaller_subset_def)
qed


definition nf_rule_impl where
  "nf_rule_impl S R SR h = (let (f, n) = h in
     let states = List.n_lists n S in
     let nlhs_inst = filter (λ qs. check_intance_lhs qs f R) states in
     map (λ qs. TA_rule f qs (min_elem (BFun f qs) SR)) nlhs_inst)"

abbreviation nf_rules_impl where
  "nf_rules_impl R ℱ ≡ concat (map (nf_rule_impl (states_impl R) (map term_to_bot_term R) (psubt_bot_impl R)) ℱ)"

(* Section proves that the implementation constructs the same rule set *)

lemma nf_rules_in_impl:
  assumes "TA_rule f qs q |∈| nf_rules (fset_of_list R) (fset_of_list ℱ)"
  shows "TA_rule f qs q |∈| fset_of_list (nf_rules_impl R ℱ)"
proof -
  have funas: "(f, length qs) ∈ set ℱ" and st: "fset_of_list qs |⊆| fstates (fset_of_list R)"
   and nlhs: "¬(∃ s ∈ (set R). s⊥ ≤b BFun f qs)"
   and min: "q = bound_max (BFun f qs) (psubt_lhs_bot (set R))"
    using assms by (auto simp add: nf_rules_fmember simp flip: fset_of_list_elem fmember.rep_eq)
  then have st_impl: "qs |∈| fset_of_list (List.n_lists (length qs) (states_impl R))"
    by (auto simp add: fset_of_list_elem subset_code(1) set_n_lists
        fset_of_list.rep_eq less_eq_fset.rep_eq fstates.rep_eq)
  from nlhs have nlhs_impl: "check_intance_lhs qs f (map term_to_bot_term R)"
    by (auto simp: list.pred_set)
  have min_impl: "q = min_elem (BFun f qs) (psubt_bot_impl R)"
    using bound_impl min
    by (auto simp flip: psubt_bot_impl)
  then show ?thesis using funas nlhs_impl funas st_impl unfolding nf_rule_impl_def
    by (auto simp: fset_of_list_elem)
qed


lemma nf_rules_impl_in_rules:
  assumes "TA_rule f qs q |∈| fset_of_list (nf_rules_impl R ℱ)"
  shows "TA_rule f qs q |∈| nf_rules (fset_of_list R) (fset_of_list ℱ)"
proof -
  have funas: "(f, length qs) ∈ set ℱ"
   and st_impl: "qs |∈| fset_of_list (List.n_lists (length qs) (states_impl R))"
   and nlhs_impl: "check_intance_lhs qs f (map term_to_bot_term R)"
   and min: "q = min_elem (BFun f qs) (psubt_bot_impl R)" using assms
    by (auto simp add: set_n_lists nf_rule_impl_def fset_of_list_elem)    
  from st_impl have st: "fset_of_list qs |⊆| fstates (fset_of_list R)"
    by (force simp: set_n_lists fset_of_list_elem fstates.rep_eq fmember.rep_eq fset_of_list.rep_eq)
  from nlhs_impl have nlhs: "¬(∃ l ∈ (set R). l⊥ ≤b BFun f qs)"
    by auto (metis (no_types, lifting) Ball_set_list_all in_set_idx length_map nth_map nth_mem)
  have "q = bound_max (BFun f qs) (psubt_lhs_bot (set R))"
    using bound_impl min
    by (auto simp flip: psubt_bot_impl)
  then show ?thesis using funas st nlhs
    by (auto simp add: nf_rules_fmember fset_of_list_elem fset_of_list.rep_eq)
qed

lemma rule_set_eq:
  shows "nf_rules (fset_of_list R) (fset_of_list ℱ) = fset_of_list (nf_rules_impl R ℱ)" (is "?Ls = ?Rs")
proof -
  {fix r assume "r |∈| ?Ls" then have "r |∈| ?Rs"
      using nf_rules_in_impl[where ?R = R and ?ℱ = ℱ]
      by (cases r) auto}
  moreover
  {fix r assume "r |∈| ?Rs" then have "r |∈| ?Ls"
      using nf_rules_impl_in_rules[where ?R = R and ?ℱ = ℱ]
      by (cases r) auto}
  ultimately show ?thesis by blast
qed

(* Code equation for normal form TA *)

lemma fstates_code[code]:
  "fstates R = fset_of_list (states_impl (sorted_list_of_fset R))"
  by (auto simp: fmember.rep_eq fstates.rep_eq fset_of_list.rep_eq)

lemma nf_ta_code [code]:
  "nf_ta R ℱ = TA (fset_of_list (nf_rules_impl (sorted_list_of_fset R) (sorted_list_of_fset ℱ))) {||}"
  unfolding nf_ta_def using rule_set_eq[of "sorted_list_of_fset R" "sorted_list_of_fset ℱ"]
  by (intro TA_equalityI) auto

(*
export_code nf_ta in Haskell
*)

end

Theory Context_Extensions

theory Context_Extensions
  imports Regular_Tree_Relations.Ground_Ctxt
    Regular_Tree_Relations.Ground_Closure
    Ground_MCtxt
begin

section ‹Multihole context and context closures over predicates›

definition gctxtex_onp where
  "gctxtex_onp P ℛ = {(C⟨s⟩G, C⟨t⟩G) | C s t. P C ∧ (s, t) ∈ ℛ}"

definition gmctxtex_onp where
  "gmctxtex_onp P ℛ = {(fill_gholes C ss, fill_gholes C ts) | C ss ts.
    num_gholes C = length ss ∧ length ss = length ts ∧ P C ∧ (∀ i < length ts. (ss ! i , ts ! i) ∈ ℛ)}"

definition compatible_p where
  "compatible_p P Q ≡ (∀ C. P C ⟶ Q (gmctxt_of_gctxt C))"

subsection ‹Elimination and introduction rules for the extensions›

lemma gctxtex_onpE [elim]:
  assumes "(s, t) ∈ gctxtex_onp P ℛ"
  obtains C u v where "s = C⟨u⟩G" "t = C⟨v⟩G" "P C" "(u, v) ∈ ℛ"
  using assms unfolding gctxtex_onp_def by auto

lemma gctxtex_onp_neq_rootE [elim]:
  assumes "(GFun f ss, GFun g ts) ∈ gctxtex_onp P ℛ" and "f ≠ g"
  shows "(GFun f ss, GFun g ts) ∈ ℛ"
proof -
  obtain C u v where "GFun f ss = C⟨u⟩G" "GFun g ts = C⟨v⟩G" "(u, v) ∈ ℛ"
    using assms(1) by auto
  then show ?thesis using assms(2)
    by (cases C) auto
qed

lemma gctxtex_onp_neq_lengthE [elim]:
  assumes "(GFun f ss, GFun g ts) ∈ gctxtex_onp P ℛ" and "length ss ≠ length ts"
  shows "(GFun f ss, GFun g ts) ∈ ℛ"
proof -
  obtain C u v where "GFun f ss = C⟨u⟩G" "GFun g ts = C⟨v⟩G" "(u, v) ∈ ℛ"
    using assms(1) by auto
  then show ?thesis using assms(2)
    by (cases C) auto
qed

lemma gmctxtex_onpE [elim]:
  assumes "(s, t) ∈ gmctxtex_onp P ℛ"
  obtains C us vs where "s = fill_gholes C us" "t = fill_gholes C vs" "num_gholes C = length us"
    "length us = length vs" "P C" "∀ i < length vs. (us ! i, vs ! i) ∈ ℛ"
  using assms unfolding gmctxtex_onp_def by auto

lemma gmctxtex_onpE2 [elim]:
  assumes "(s, t) ∈ gmctxtex_onp P ℛ"
  obtains C us vs where "s =Gf (C, us)" "t =Gf (C, vs)"
    "P C" "∀ i < length vs. (us ! i, vs ! i) ∈ ℛ"
  using gmctxtex_onpE[OF assms] by (metis eq_gfill.intros)

lemma gmctxtex_onp_neq_rootE [elim]:
  assumes "(GFun f ss, GFun g ts) ∈ gmctxtex_onp P ℛ" and "f ≠ g"
  shows "(GFun f ss, GFun g ts) ∈ ℛ"
proof -
  obtain C us vs where "GFun f ss = fill_gholes C us" "GFun g ts = fill_gholes C vs"
    "num_gholes C = length us" "length us = length vs" "∀ i < length vs. (us ! i, vs ! i) ∈ ℛ"
    using assms(1) by auto
  then show ?thesis using assms(2)
    by (cases C; cases us; cases vs) auto
qed

lemma gmctxtex_onp_neq_lengthE [elim]:
  assumes "(GFun f ss, GFun g ts) ∈ gmctxtex_onp P ℛ" and "length ss ≠ length ts"
  shows "(GFun f ss, GFun g ts) ∈ ℛ"
proof -
  obtain C us vs where "GFun f ss = fill_gholes C us" "GFun g ts = fill_gholes C vs"
    "num_gholes C = length us" "length us = length vs" "∀ i < length vs. (us ! i, vs ! i) ∈ ℛ"
    using assms(1) by auto
  then show ?thesis using assms(2)
    by (cases C; cases us; cases vs) auto
qed

lemma gmctxtex_onp_listE:
  assumes "∀ i < length ts. (ss ! i, ts ! i) ∈ gmctxtex_onp Q ℛ" "length ss = length ts"
  obtains Ds sss tss where "length ts = length Ds" "length Ds = length sss" "length sss = length tss"
    "∀ i < length tss. length (sss ! i) = length (tss ! i)" "∀ D ∈ set Ds. Q D"
    "∀ i < length tss. ss ! i =Gf (Ds ! i, sss ! i)" "∀ i < length tss. ts ! i =Gf (Ds ! i, tss ! i)"
    "∀ i < length (concat tss). (concat sss ! i, concat tss ! i) ∈ ℛ"
proof -
 let ?P = "λ W i. ss ! i =Gf (fst W, fst (snd W)) ∧ ts ! i =Gf (fst W, snd (snd W)) ∧
    Q (fst W) ∧ (∀ i < length (snd (snd W)). (fst (snd W) ! i, snd (snd W) ! i) ∈ ℛ)"
  have "∀ i < length ts. ∃ x. ?P x i" using assms gmctxtex_onpE2[of "ss ! i" "ts ! i" Q ℛ for i]
    by auto metis
  from Ex_list_of_length_P[OF this] obtain W where
    P: "length W = length ts" "∀ i < length ts. ?P (W ! i) i" by blast
  define Ds sss tss where "Ds ≡ map fst W" and "sss ≡ map (fst ∘ snd) W" and "tss ≡ map (snd ∘ snd) W"
  from P have len: "length ts = length Ds" "length Ds = length sss" "length sss = length tss" and
    pred: "∀ D ∈ set Ds. Q D" and
    split: "∀ i < length Ds. ss ! i =Gf (Ds ! i, sss ! i) ∧ ts ! i =Gf (Ds ! i, tss ! i)"and
    rec: "∀i < length Ds. ∀ j < length (tss ! i). (sss ! i ! j, tss ! i ! j) ∈ ℛ"
    using assms(2) by (auto simp: Ds_def sss_def tss_def dest!: in_set_idx)
  from len split have inn: "∀ i < length tss. length (sss ! i) = length (tss ! i)"
    by auto (metis eqgfE(2))
  from inn len rec have "∀ i < length (concat tss). (concat sss ! i, concat tss ! i) ∈ ℛ"
    by (intro concat_nth_nthI) auto
  then show "(⋀Ds sss tss. length ts = length Ds ⟹ length Ds = length sss ⟹ length sss = length tss ⟹
        ∀i<length tss. length (sss ! i) = length (tss ! i) ⟹ ∀D∈set Ds. Q D ⟹
        ∀i<length tss. ss ! i =Gf (Ds ! i, sss ! i) ⟹ ∀i<length tss. ts ! i =Gf (Ds ! i, tss ! i) ⟹
        ∀i<length (concat tss). (concat sss ! i, concat tss ! i) ∈ ℛ ⟹ thesis) ⟹ thesis"
    using pred split inn len by auto
qed

lemma gmctxtex_onp_doubleE [elim]:
  assumes "(s, t) ∈ gmctxtex_onp P (gmctxtex_onp Q ℛ)"
  obtains C Ds ss ts us vs where "s =Gf (C, ss)" "t =Gf (C, ts)" "P C" "∀ D ∈ set Ds. Q D"
    "num_gholes C = length Ds" "length Ds = length ss" "length ss = length ts" "length ts = length us" "length us = length vs"
    "∀ i < length Ds. ss ! i =Gf (Ds ! i, us ! i) ∧ ts ! i =Gf (Ds ! i, vs ! i)"
    "∀ i < length Ds. ∀ j < length (vs ! i). (us ! i ! j, vs ! i ! j) ∈ ℛ"
proof -
  from gmctxtex_onpE2[OF assms] obtain C ss ts where
    split: "s =Gf (C, ss)" "t =Gf (C, ts)" and
    len: "num_gholes C = length ss" "length ss = length ts" and
    pred: "P C" and rec: "∀ i < length ts. (ss ! i, ts ! i) ∈ gmctxtex_onp Q ℛ"
      by (metis eqgfE(2))
  let ?P = "λ W i. ss ! i =Gf (fst W, fst (snd W)) ∧ ts ! i =Gf (fst W, snd (snd W)) ∧
    Q (fst W) ∧ (∀ i < length (snd (snd W)). (fst (snd W) ! i, snd (snd W) ! i) ∈ ℛ)"
  have "∀ i < length ts. ∃ x. ?P x i" using rec gmctxtex_onpE2[of "ss ! i" "ts ! i" Q ℛ for i]
    by auto metis
  from Ex_list_of_length_P[OF this] obtain W where
    P: "length W = length ts" "∀ i < length ts. ?P (W ! i) i" by blast
  define Ds us vs where "Ds ≡ map fst W" and "us ≡ map (fst ∘ snd) W" and "vs ≡ map (snd ∘ snd) W"
  from P have len': "length Ds = length ss" "length ss = length ts" "length ts = length us" "length us = length vs" and
    pred': "∀ D ∈ set Ds. Q D" and
    split': "∀ i < length Ds. ss ! i =Gf (Ds ! i, us ! i) ∧ ts ! i =Gf (Ds ! i, vs ! i)"and
    rec': "∀i < length Ds. ∀ j < length (vs ! i). (us ! i ! j, vs ! i ! j) ∈ ℛ"
  using len by (auto simp: Ds_def us_def vs_def dest!: in_set_idx)
  from len' len have "num_gholes C = length Ds" by simp
  from this split pred pred' len' split' rec' len
  show "(⋀C ss ts Ds us vs. s =Gf (C, ss) ⟹ t =Gf (C, ts) ⟹ P C ⟹
    ∀D∈set Ds. Q D ⟹ num_gholes C = length Ds ⟹ length Ds = length ss ⟹ length ss = length ts ⟹
    length ts = length us ⟹ length us = length vs ⟹
    ∀i<length Ds. ss ! i =Gf (Ds ! i, us ! i) ∧ ts ! i =Gf (Ds ! i, vs ! i) ⟹
    ∀i<length Ds. ∀j<length (vs ! i). (us ! i ! j, vs ! i ! j) ∈ ℛ ⟹ thesis) ⟹ thesis"
      by blast
qed

lemma gctxtex_onpI [intro]:
  assumes "P C" and "(s, t) ∈ ℛ"
  shows "(C⟨s⟩G, C⟨t⟩G) ∈ gctxtex_onp P ℛ"
  using assms by (auto simp: gctxtex_onp_def)

lemma gmctxtex_onpI [intro]:
  assumes "P C" and "num_gholes C = length us" and "length us = length vs" 
    and "∀ i < length vs. (us ! i, vs ! i) ∈ ℛ"
  shows "(fill_gholes C us, fill_gholes C vs) ∈ gmctxtex_onp P ℛ"
  using assms unfolding gmctxtex_onp_def
  by force

lemma gmctxtex_onp_arg_monoI:
  assumes "P GMHole"
  shows "ℛ ⊆ gmctxtex_onp P ℛ" using assms
proof (intro subsetI)
  fix s assume mem: "s ∈ ℛ"
  have *: "(fill_gholes GMHole [fst s], fill_gholes GMHole [snd s]) = s" by auto
  have "(fill_gholes GMHole [fst s], fill_gholes GMHole [snd s]) ∈ gmctxtex_onp P ℛ"
    by (intro gmctxtex_onpI) (auto simp: assms mem)
  then show "s ∈ gmctxtex_onp P ℛ" unfolding * .
qed

lemma gmctxtex_onpI2 [intro]:
  assumes "P C" and "s =Gf (C, ss)" "t =Gf (C, ts)"
    and "∀ i < length ts. (ss ! i, ts ! i) ∈ ℛ"
  shows "(s, t) ∈ gmctxtex_onp P ℛ"
  using eqgfE[OF assms(2)] eqgfE[OF assms(3)]
  using gmctxtex_onpI[of P, OF assms(1) _ _ assms(4)]
  by (simp add: ‹num_gholes C = length ss›)

lemma gctxtex_onp_hold_cond [simp]:
  "(s, t) ∈ gctxtex_onp P ℛ ⟹ groot s ≠ groot t ⟹ P □G"
  "(s, t) ∈ gctxtex_onp P ℛ ⟹ length (gargs s) ≠ length (gargs t) ⟹ P □G"
  by (auto elim!: gctxtex_onpE, case_tac C; auto)+

subsection ‹Monotonicity rules for the extensions›

lemma gctxtex_onp_rel_mono:
  "ℒ ⊆ ℛ ⟹ gctxtex_onp P ℒ ⊆ gctxtex_onp P ℛ"
  unfolding gctxtex_onp_def by auto

lemma gmctxtex_onp_rel_mono:
  "ℒ ⊆ ℛ ⟹ gmctxtex_onp P ℒ ⊆ gmctxtex_onp P ℛ"
  unfolding gmctxtex_onp_def
  by auto (metis subsetD)

lemma compatible_p_gctxtex_gmctxtex_subseteq [dest]:
  "compatible_p P Q ⟹ gctxtex_onp P ℛ ⊆ gmctxtex_onp Q ℛ"
  unfolding compatible_p_def
  by (auto simp: apply_gctxt_fill_gholes gmctxtex_onpI)

lemma compatible_p_mono1:
  "P ≤ R ⟹ compatible_p R Q ⟹ compatible_p P Q"
  unfolding compatible_p_def by auto

lemma compatible_p_mono2:
  "Q ≤ R ⟹ compatible_p P Q ⟹ compatible_p P R"
  unfolding compatible_p_def by auto

lemma gctxtex_onp_mono [intro]:
  "P ≤ Q ⟹ gctxtex_onp P ℛ ⊆ gctxtex_onp Q ℛ"
  by auto

lemma gctxtex_onp_mem:
  "P ≤ Q ⟹ (s, t) ∈ gctxtex_onp P ℛ ⟹ (s, t) ∈ gctxtex_onp Q ℛ"
  by auto

lemma gmctxtex_onp_mono [intro]:
  "P ≤ Q ⟹ gmctxtex_onp P ℛ ⊆ gmctxtex_onp Q ℛ"
  by (auto elim!: gmctxtex_onpE)

lemma gmctxtex_onp_mem:
  "P ≤ Q ⟹ (s, t) ∈ gmctxtex_onp P ℛ ⟹ (s, t) ∈ gmctxtex_onp Q ℛ"
  by (auto dest!: gmctxtex_onp_mono)

lemma gctxtex_eqI [intro]:
  "P = Q ⟹ ℛ = ℒ ⟹ gctxtex_onp P ℛ = gctxtex_onp Q ℒ"
  by auto

lemma gmctxtex_eqI [intro]:
  "P = Q ⟹ ℛ = ℒ ⟹ gmctxtex_onp P ℛ = gmctxtex_onp Q ℒ"
  by auto

subsection ‹Relation swap and converse›

lemma swap_gctxtex_onp:
  "gctxtex_onp P (prod.swap ` ℛ) = prod.swap ` gctxtex_onp P ℛ"
  by (auto simp: gctxtex_onp_def image_def) force+

lemma swap_gmctxtex_onp:
  "gmctxtex_onp P (prod.swap ` ℛ) = prod.swap ` gmctxtex_onp P ℛ"
  by (auto simp: gmctxtex_onp_def image_def) force+

lemma converse_gctxtex_onp:
  "(gctxtex_onp P ℛ)¯ = gctxtex_onp P (ℛ¯)"
  by (auto simp: gctxtex_onp_def)

lemma converse_gmctxtex_onp:
  "(gmctxtex_onp P ℛ)¯ = gmctxtex_onp P (ℛ¯)"
  by (auto simp: gmctxtex_onp_def) force+

subsection ‹Subset equivalence for context extensions over predicates›

lemma gctxtex_onp_closure_predI:
  assumes "⋀ C s t. P C ⟹ (s, t) ∈ ℛ ⟹ (C⟨s⟩G, C⟨t⟩G) ∈ ℛ"
  shows "gctxtex_onp P ℛ ⊆ ℛ"
  using assms by auto

lemma gmctxtex_onp_closure_predI:
  assumes "⋀ C ss ts. P C ⟹ num_gholes C = length ss ⟹ length ss = length ts ⟹
    (∀ i < length ts. (ss ! i, ts ! i) ∈ ℛ) ⟹ (fill_gholes C ss, fill_gholes C ts) ∈ ℛ"
  shows "gmctxtex_onp P ℛ ⊆ ℛ"
  using assms by auto

lemma gctxtex_onp_closure_predE:
  assumes "gctxtex_onp P ℛ ⊆ ℛ"
  shows  "⋀ C s t. P C ⟹ (s, t) ∈ ℛ ⟹ (C⟨s⟩G, C⟨t⟩G) ∈ ℛ"
  using assms by auto

lemma gctxtex_closure [intro]:
  "P □G ⟹ ℛ ⊆ gctxtex_onp P ℛ"
  by (auto simp: gctxtex_onp_def) force

lemma gmctxtex_closure [intro]:
  assumes "P GMHole"
  shows "ℛ ⊆ (gmctxtex_onp P ℛ)"
proof -
  {fix s t assume "(s, t) ∈ ℛ" then have "(s, t) ∈ gmctxtex_onp P ℛ" 
      using gmctxtex_onpI[of P GMHole "[s]" "[t]"] assms by auto}
  then show ?thesis by auto
qed

lemma gctxtex_pred_cmp_subseteq:
  assumes "⋀ C D. P C ⟹ Q D ⟹ Q (C ∘Gc D)"
  shows "gctxtex_onp P (gctxtex_onp Q ℛ) ⊆ gctxtex_onp Q ℛ"
  using assms by (auto simp: gctxtex_onp_def) (metis ctxt_ctxt_compose)

lemma gctxtex_pred_cmp_subseteq2:
  assumes "⋀ C D. P C ⟹ Q D ⟹ P (C ∘Gc D)"
  shows "gctxtex_onp P (gctxtex_onp Q ℛ) ⊆ gctxtex_onp P ℛ"
  using assms by (auto simp: gctxtex_onp_def) (metis ctxt_ctxt_compose)

lemma gmctxtex_pred_cmp_subseteq:
  assumes "⋀ C D. C ≤ D ⟹ P C ⟹ (∀ Ds ∈ set (sup_gmctxt_args C D). Q Ds) ⟹ Q D"
  shows "gmctxtex_onp P (gmctxtex_onp Q ℛ) ⊆ gmctxtex_onp Q ℛ" (is "?Ls ⊆ ?Rs")
proof -
  {fix s t assume "(s, t) ∈ ?Ls"
    then obtain C Ds ss ts us vs where
      split: "s =Gf (C, ss)" "t =Gf (C, ts)" and
      len: "num_gholes C = length Ds" "length Ds = length ss" "length ss = length ts"
        "length ts = length us" "length us = length vs" and
      pred: "P C" "∀ D ∈ set Ds. Q D" and
      split': "∀ i < length Ds. ss ! i =Gf (Ds ! i, us ! i) ∧ ts ! i =Gf (Ds ! i, vs ! i)" and
      rec: " ∀i<length Ds. ∀j<length (vs ! i). (us ! i ! j, vs ! i ! j) ∈ ℛ"
      by auto
    from pred(2) assms[OF _ pred(1), of "fill_gholes_gmctxt C Ds"] len
    have P: "Q (fill_gholes_gmctxt C Ds)"
      by (simp add: fill_gholes_gmctxt_less_eq)
    have mem: "∀ i < length (concat vs). (concat us ! i, concat vs ! i) ∈ ℛ"
      using rec split' len
      by (intro concat_nth_nthI) (auto, metis eqgfE(2))
    have "(s, t) ∈ ?Rs" using split' split len
      by (intro gmctxtex_onpI2[of Q, OF P _ _ mem])
        (metis eqgfE(1) fill_gholes_gmctxt_sound)+}
  then show ?thesis by auto
qed

lemma gmctxtex_pred_cmp_subseteq2:
  assumes "⋀ C D. C ≤ D ⟹ P C ⟹ (∀ Ds ∈ set (sup_gmctxt_args C D). Q Ds) ⟹ P D"
  shows "gmctxtex_onp P (gmctxtex_onp Q ℛ) ⊆ gmctxtex_onp P ℛ" (is "?Ls ⊆ ?Rs")
proof -
    {fix s t assume "(s, t) ∈ ?Ls"
    then obtain C Ds ss ts us vs where
      split: "s =Gf (C, ss)" "t =Gf (C, ts)" and
      len: "num_gholes C = length Ds" "length Ds = length ss" "length ss = length ts"
        "length ts = length us" "length us = length vs" and
      pred: "P C" "∀ D ∈ set Ds. Q D" and
      split': "∀ i < length Ds. ss ! i =Gf (Ds ! i, us ! i) ∧ ts ! i =Gf (Ds ! i, vs ! i)" and
      rec: " ∀i<length Ds. ∀j<length (vs ! i). (us ! i ! j, vs ! i ! j) ∈ ℛ"
      by auto
    from pred(2) assms[OF _ pred(1), of "fill_gholes_gmctxt C Ds"] len
    have P: "P (fill_gholes_gmctxt C Ds)"
      by (simp add: fill_gholes_gmctxt_less_eq)
    have mem: "∀ i < length (concat vs). (concat us ! i, concat vs ! i) ∈ ℛ" using rec split' len
      by (intro concat_nth_nthI) (auto, metis eqgfE(2))
    have "(s, t) ∈ ?Rs" using split' split len
      by (intro gmctxtex_onpI2[of P, OF P _ _ mem])
        (metis eqgfE(1) fill_gholes_gmctxt_sound)+}
  then show ?thesis by auto
qed

lemma gctxtex_onp_idem [simp]:
  assumes "P □G" and "⋀ C D. P C ⟹ Q D ⟹ Q (C ∘Gc D)"
  shows "gctxtex_onp P (gctxtex_onp Q ℛ) = gctxtex_onp Q ℛ" (is "?Ls = ?Rs")
  by (simp add: assms gctxtex_pred_cmp_subseteq gctxtex_closure subset_antisym)

lemma gctxtex_onp_idem2 [simp]:
  assumes "Q □G" and "⋀ C D. P C ⟹ Q D ⟹ P (C ∘Gc D)"
  shows "gctxtex_onp P (gctxtex_onp Q ℛ) = gctxtex_onp P ℛ" (is "?Ls = ?Rs")
  using gctxtex_pred_cmp_subseteq2[of P Q, OF assms(2)]
  using gctxtex_closure[of Q, OF assms(1)] in_mono
  by auto fastforce

lemma gmctxtex_onp_idem [simp]:
  assumes "P GMHole"
    and "⋀ C D. C ≤ D ⟹ P C ⟹ (∀ Ds ∈ set (sup_gmctxt_args C D). Q Ds) ⟹ Q D"
  shows "gmctxtex_onp P (gmctxtex_onp Q ℛ) = gmctxtex_onp Q ℛ"
  using gmctxtex_pred_cmp_subseteq[of P Q ℛ] gmctxtex_closure[of P] assms
  by auto

subsection ‹@{const gmctxtex_onp} subset equivalence @{const gctxtex_onp} transitive closure›

text ‹The following definition demands that if we arbitrarily fill a multihole context C with terms
  induced by signature F such that one hole remains then the predicate Q holds›
definition "gmctxt_p_inv C ℱ Q ≡ (∀ D. gmctxt_closing C D ⟶ num_gholes D = 1 ⟶ funas_gmctxt D ⊆ ℱ
  ⟶ Q (gctxt_of_gmctxt D))"

lemma gmctxt_p_invE:
  "gmctxt_p_inv C ℱ Q ⟹ C ≤ D ⟹ ghole_poss D ⊆ ghole_poss C ⟹ num_gholes D = 1 ⟹
    funas_gmctxt D ⊆ ℱ ⟹ Q (gctxt_of_gmctxt D)"
  unfolding gmctxt_closing_def gmctxt_p_inv_def
  using less_eq_gmctxt_prime by blast

lemma gmctxt_closing_gmctxt_p_inv_comp:
  "gmctxt_closing C D ⟹ gmctxt_p_inv C ℱ Q ⟹ gmctxt_p_inv D ℱ Q"
  unfolding gmctxt_closing_def gmctxt_p_inv_def
  by auto (meson less_eq_gmctxt_prime order_trans)

lemma GMHole_gmctxt_p_inv_GHole [simp]:
  "gmctxt_p_inv GMHole ℱ Q ⟹ Q □G"
  by (auto dest: gmctxt_p_invE)
  

lemma gmctxtex_onp_gctxtex_onp_trancl:
  assumes sig: "⋀ C. P C ⟹ 0 < num_gholes C ∧ funas_gmctxt C ⊆ ℱ" "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
    and "⋀ C. P C ⟹ gmctxt_p_inv C ℱ Q"
  shows "gmctxtex_onp P ℛ ⊆ (gctxtex_onp Q ℛ)+"
proof
  fix s t assume "(s, t) ∈ gmctxtex_onp P ℛ"
  then obtain C ss ts where
    split: "s = fill_gholes C ss" "t = fill_gholes C ts" and
    inv: "num_gholes C = length ss" "num_gholes C = length ts" and
    pred: "P C" and rec: "∀ i < length ts. (ss ! i, ts ! i) ∈ ℛ"
    by auto
  from pred have "0 < num_gholes C" "funas_gmctxt C ⊆ ℱ" using sig by auto
  from this inv assms(3)[OF pred] rec show "(s, t) ∈ (gctxtex_onp Q ℛ)+" unfolding split
  proof (induct "num_gholes C" arbitrary: C ss ts)
    case (Suc x) note IS = this then show ?case
    proof (cases C)
      case GMHole then show ?thesis
        using IS(2-) gctxtex_closure unfolding gmctxt_p_inv_def gmctxt_closing_def
        by (metis One_nat_def fill_gholes_GMHole gctxt_of_gmctxt.simps(1)
         gmctxt_order_bot.bot.extremum_unique less_eq_gmctxt_prime num_gholes.simps(1) r_into_trancl' subsetD subsetI)
    next
      case [simp]: (GMFun f Cs) note IS = IS[unfolded GMFun]
      let ?rep = "λ x. replicate (num_gholes (GMFun f Cs) - 1) x"
      let ?Ds1 = "?rep GMHole @ [gmctxt_of_gterm (last ss)]"
      let ?Ds2 = "map gmctxt_of_gterm (butlast ts) @ [GMHole]"
      let ?D1 = "fill_gholes_gmctxt (GMFun f Cs) ?Ds1"
      let ?D2 = "fill_gholes_gmctxt (GMFun f Cs) ?Ds2"
      have holes: "num_gholes (GMFun f Cs) = length ?Ds1" "num_gholes (GMFun f Cs) = length ?Ds2"
        using IS(2, 5, 6) by auto
      from holes(2) have [simp]: "num_gholes ?D2 = Suc 0"
        by (auto simp: num_gholes_fill_gholes_gmctxt simp del: fill_gholes_gmctxt.simps)
      from holes(1) have h: "x = num_gholes ?D1" using IS(2)
        by (auto simp: num_gholes_fill_gholes_gmctxt simp del: fill_gholes_gmctxt.simps)
      from holes have less: "GMFun f Cs ≤ ?D1" "GMFun f Cs ≤ ?D2"
        by (auto simp del: fill_gholes_gmctxt.simps intro: fill_gholes_gmctxt_less_eq)
      have "ghole_poss ?D1 ⊆ ghole_poss (GMFun f Cs)" using less(1) IS(2, 3)
        by (intro fill_gholes_gmctxt_ghole_poss_subseteq) (auto simp: nth_append)
      then have ext: "gmctxt_p_inv ?D1 ℱ Q" using less(1) IS(7)
        using gmctxt_closing_def gmctxt_closing_gmctxt_p_inv_comp less_eq_gmctxt_prime
        by blast
      have split_last_D1_ss: "fill_gholes C (butlast ts @ [last ss]) =Gf (?D1, concat (map (λ x. [x]) (butlast ts) @ [[]]))"
        using holes(1) IS(2, 5, 6) unfolding GMFun
        by (intro fill_gholes_gmctxt_sound)
          (auto simp: nth_append eq_gfill.simps nth_butlast)
      have split_last_D2_ss: "fill_gholes C (butlast ts @ [last ss]) =Gf (?D2, concat (?rep [] @ [[last ss]]))"
        using holes(2) IS(2, 5, 6) unfolding GMFun
        by (intro fill_gholes_gmctxt_sound) (auto simp: nth_append
           eq_gfill.simps nth_butlast last_conv_nth intro: last_nthI)
      have split_last_ts: "fill_gholes C ts =Gf (?D2, concat (?rep [] @ [[last ts]]))"
        using holes(2) IS(2, 5, 6) unfolding GMFun
        by (intro fill_gholes_gmctxt_sound) (auto simp: nth_append
           eq_gfill.simps nth_butlast last_conv_nth intro: last_nthI)
      from eqgfE[OF split_last_ts] have last_eq: "fill_gholes C ts = fill_gholes ?D2 [last ts]"
        by (auto simp del: fill_gholes.simps fill_gholes_gmctxt.simps)
      have trans: "fill_gholes ?D1 (butlast ts) = fill_gholes ?D2 [last ss]"
        using eqgfE[OF split_last_D1_ss] eqgfE[OF split_last_D2_ss]
        by (auto simp del: fill_gholes.simps fill_gholes_gmctxt.simps)
      have "ghole_poss ?D2 ⊆ ghole_poss (GMFun f Cs)" using less(2) IS(2, 3, 6)
        by (intro fill_gholes_gmctxt_ghole_poss_subseteq) (auto simp: nth_append)
      then have "Q (gctxt_of_gmctxt ?D2)" using less(2)
        using subsetD[OF assms(2)] IS(2 -  6, 8) holes(2)
        by (intro gmctxt_p_invE[OF IS(7)])
          (auto simp del: fill_gholes_gmctxt.simps simp: num_gholes_fill_gholes_gmctxt
            in_set_conv_nth 𝒯G_equivalent_def nth_butlast, metis less_SucI subsetD)
      from gctxtex_onpI[of Q _ "last ss" "last ts" ℛ, OF this] IS(2, 3, 5, 6, 8)
      have mem: "(fill_gholes ?D2 [last ss], fill_gholes ?D2 [last ts]) ∈ gctxtex_onp Q ℛ"
        using fill_gholes_apply_gctxt[of ?D2 "last ss"]
        using fill_gholes_apply_gctxt[of ?D2 "last ts"]
        by (auto simp del: gctxt_of_gmctxt.simps fill_gholes_gmctxt.simps fill_gholes.simps)
          (metis IS(2) IS(3) append_butlast_last_id diff_Suc_1 length_butlast
           length_greater_0_conv lessI nth_append_length)
      show ?thesis
      proof (cases x)
        case 0 then show ?thesis using mem IS(2 - 6) eqgfE[OF split_last_D2_ss] last_eq
          by (cases ss; cases ts)
          (auto simp del: gctxt_of_gmctxt.simps fill_gholes_gmctxt.simps fill_gholes.simps,
            metis IS(3, 5) length_0_conv less_not_refl)
      next
        case [simp]: (Suc nat)
        have "fill_gholes C ss =Gf (?D1, concat (map (λ x. [x]) (butlast ss) @ [[]]))"
          using holes(1) IS(2, 5, 6) unfolding GMFun
          by (intro fill_gholes_gmctxt_sound)
            (auto simp del: fill_gholes_gmctxt.simps fill_gholes.simps
              simp: nth_append nth_butlast eq_gfill.intros last_nthI)
        from eqgfE[OF this] have l: "fill_gholes C ss = fill_gholes ?D1 (butlast ss)"
          by (auto simp del: fill_gholes_gmctxt.simps fill_gholes.simps)
        from IS(1)[OF h _ _ _ _ ext, of "butlast ss" "butlast ts"] IS(2-) holes(2) h assms(2)
        have "(fill_gholes ?D1 (butlast ss), fill_gholes ?D1 (butlast ts)) ∈ (gctxtex_onp Q ℛ)+"
          by (auto simp del: gctxt_of_gmctxt.simps fill_gholes_gmctxt.simps fill_gholes.simps
            simp: 𝒯G_equivalent_def)
            (smt Suc.prems(1) Suc.prems(4) diff_Suc_1 last_conv_nth length_butlast
           length_greater_0_conv lessI less_SucI mem_Sigma_iff nth_butlast sig(2) subset_iff 𝒯G_funas_gterm_conv)
        then have "(fill_gholes ?D1 (butlast ss), fill_gholes ?D2 [last ts]) ∈ (gctxtex_onp Q ℛ)+"
          using mem unfolding trans
          by (auto simp del: gctxt_of_gmctxt.simps fill_gholes_gmctxt.simps fill_gholes.simps)
        then show ?thesis unfolding last_eq l
          by (auto simp del:  fill_gholes_gmctxt.simps fill_gholes.simps)
      qed
    qed
  qed auto
qed

lemma gmctxtex_onp_gctxtex_onp_rtrancl:
  assumes sig: "⋀ C. P C ⟹ funas_gmctxt C ⊆ ℱ" "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
    and "⋀ C D. P C ⟹ gmctxt_p_inv C ℱ Q"
  shows "gmctxtex_onp P ℛ ⊆ (gctxtex_onp Q ℛ)*"
proof
  fix s t assume "(s, t) ∈ gmctxtex_onp P ℛ"
  then obtain C ss ts where
    split: "s = fill_gholes C ss" "t = fill_gholes C ts" and
    inv: "num_gholes C = length ss" "num_gholes C = length ts" and
    pred: "P C" and rec: "∀ i < length ts. (ss ! i, ts ! i) ∈ ℛ"
    by auto
  then show "(s, t) ∈ (gctxtex_onp Q ℛ)*"
  proof (cases "num_gholes C")
    case 0 then show ?thesis using inv unfolding split
      by auto
  next
    case (Suc nat)
    from split inv pred rec assms
    have "(s, t) ∈ gmctxtex_onp (λ C. P C ∧ 0 < num_gholes C) ℛ" unfolding split
      by auto (metis (no_types, lifting) Suc gmctxtex_onpI zero_less_Suc)
    moreover have "gmctxtex_onp (λ C. P C ∧ 0 < num_gholes C) ℛ ⊆ (gctxtex_onp Q ℛ)+" using assms
      by (intro gmctxtex_onp_gctxtex_onp_trancl) auto
    ultimately show ?thesis by auto
  qed
qed

lemma rtrancl_gmctxtex_onp_rtrancl_gctxtex_onp_eq:
  assumes sig: "⋀ C. P C ⟹ funas_gmctxt C ⊆ ℱ" "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
    and "⋀ C D. P C ⟹ gmctxt_p_inv C ℱ Q"
    and "compatible_p Q P"
  shows "(gmctxtex_onp P ℛ)* = (gctxtex_onp Q ℛ)*" (is "?Ls* = ?Rs*")
proof -
  from assms(4) have "?Rs ⊆ ?Ls" by auto
  then have "?Rs* ⊆ ?Ls*"
    by (simp add: rtrancl_mono) 
  moreover from gmctxtex_onp_gctxtex_onp_rtrancl[OF assms(1 - 3), of P]
  have "?Ls* ⊆ ?Rs*"
    by (simp add: rtrancl_subset_rtrancl) 
  ultimately show ?thesis by blast
qed

subsection ‹Extensions to reflexive transitive closures›

lemma gctxtex_onp_substep_trancl:
  assumes "gctxtex_onp P ℛ ⊆ ℛ"
  shows "gctxtex_onp P (ℛ+) ⊆ ℛ+"
proof -
  {fix s t assume "(s, t) ∈ gctxtex_onp P (ℛ+)"
    then obtain C u v where rec: "(u, v) ∈ ℛ+" "P C" and t: "s = C⟨u⟩G" "t = C⟨v⟩G"
      by auto
    from rec have "(s, t) ∈ ℛ+" unfolding t
    proof (induct)
      case (base y)
      then show ?case using assms by auto
    next
      case (step y z)
      from assms step(2, 4) have "(C⟨y⟩G, C⟨z⟩G) ∈ ℛ" by auto
      then show ?case using step by auto
    qed}
  then show ?thesis by auto
qed

lemma gctxtex_onp_substep_rtrancl:
  assumes "gctxtex_onp P ℛ ⊆ ℛ"
  shows "gctxtex_onp P (ℛ*) ⊆ ℛ*"
  using gctxtex_onp_substep_trancl[OF assms]
  by (smt gctxtex_onpE gctxtex_onpI rtrancl_eq_or_trancl subrelI subset_eq)

lemma gctxtex_onp_substep_trancl_diff_pred [intro]:
  assumes "⋀ C D. P C ⟹ Q D ⟹ Q (D ∘Gc C)"
  shows "gctxtex_onp Q ((gctxtex_onp P ℛ)+) ⊆ (gctxtex_onp Q ℛ)+"
proof
  fix s t assume "(s, t) ∈ gctxtex_onp Q ((gctxtex_onp P ℛ)+)"
  from gctxtex_onpE[OF this] obtain C u v where
    *: "s = C⟨u⟩G" "t = C⟨v⟩G" and inv: "Q C" and mem: "(u, v) ∈ (gctxtex_onp P ℛ)+"
    by blast
  show "(s, t) ∈ (gctxtex_onp Q ℛ)+" using mem * inv
  proof (induct arbitrary: s t)
    case (base y)
    then show ?case using assms
      by (auto elim!: gctxtex_onpE intro!: r_into_trancl) (metis ctxt_ctxt_compose gctxtex_onpI) 
  next
    case (step y z)
    from step(2) have "(C⟨y⟩G, C⟨z⟩G) ∈ gctxtex_onp Q ℛ"
      using assms[OF _ step(6)]
        by (auto elim!: gctxtex_onpE) (metis ctxt_ctxt_compose gctxtex_onpI) 
    then show ?case using step(3)[of s "C⟨y⟩G"] step(1, 2, 4-)
      by auto
  qed
qed

lemma gctxtcl_pres_trancl:
  assumes "(s, t) ∈ ℛ+" and "gctxtex_onp P ℛ ⊆ ℛ" and "P C"
  shows "(C⟨s⟩G, C⟨t⟩G) ∈ ℛ+"
  using gctxtex_onp_substep_trancl [OF assms(2)] assms(1, 3)
  by auto

lemma gctxtcl_pres_rtrancl:
  assumes "(s, t) ∈ ℛ*" and "gctxtex_onp P ℛ ⊆ ℛ" and "P C"
  shows "(C⟨s⟩G, C⟨t⟩G) ∈ ℛ*"
  using assms(1) gctxtcl_pres_trancl[OF _ assms(2, 3)]
  unfolding rtrancl_eq_or_trancl
  by (cases "s = t") auto


lemma gmctxtex_onp_substep_trancl: 
  assumes "gmctxtex_onp P ℛ ⊆ ℛ"
    and "Id_on (snd ` ℛ) ⊆ ℛ"
  shows "gmctxtex_onp P (ℛ+) ⊆ ℛ+"
proof -
  {fix s t assume "(s, t) ∈ gmctxtex_onp P (ℛ+)"
    from gmctxtex_onpE[OF this] obtain C us vs where
      *: "s = fill_gholes C us" "t = fill_gholes C vs" and
      len: "num_gholes C = length us" "length us = length vs" and
      inv: "P C" "∀ i < length vs. (us ! i, vs ! i) ∈ ℛ+" by auto
    have "(s, t) ∈ ℛ+" using len(2) inv(2) len(1) inv(1) unfolding *
    proof (induction rule: trancl_list_induct)
      case (base xs ys)
      then have "(fill_gholes C xs, fill_gholes C ys) ∈ ℛ" using assms(1)
        by blast
      then show ?case by auto
    next
      case (step xs ys i z)
      have sub: "set ys ⊆ snd ` ℛ" using step(1, 2)
        by (auto simp: image_def) (metis in_set_idx snd_conv tranclD2)
      from step have lft: "(fill_gholes C xs, fill_gholes C ys) ∈ ℛ+" by auto
      have "(fill_gholes C ys, fill_gholes C (ys[i := z])) ∈ gmctxtex_onp P ℛ"
        using step(3, 4) sub assms step(1, 6)
        by (intro gmctxtex_onpI[of P, OF step(7), of ys "ys[i := z]" ℛ])
          (simp add: Id_on_eqI nth_list_update subset_iff)+
      then have "(fill_gholes C ys, fill_gholes C (ys[i := z])) ∈ ℛ" using assms(1) by blast
      then show ?case using lft by auto
    qed}
  then show ?thesis by auto
qed

lemma gmctxtex_onp_substep_tranclE:
  assumes "trans ℛ" and "gmctxtex_onp Q ℛ O ℛ ⊆ ℛ" and "ℛ O gmctxtex_onp Q ℛ ⊆ ℛ"
    and "⋀ p C. P C ⟹ p ∈ poss_gmctxt C ⟹ Q (subgm_at C p)"
    and "⋀ C D. P C ⟹ P D ⟹ (C, D) ∈ comp_gmctxt ⟹ P (C ⊓ D)"
  shows "(gmctxtex_onp P ℛ)+ = gmctxtex_onp P ℛ" (is "?Ls = ?Rs")
proof
  show "?Rs ⊆ ?Ls" using trancl_mono_set by fastforce
next
  {fix s t assume "(s, t) ∈ ?Ls" then have "(s, t) ∈ ?Rs"
    proof induction
      case (step t u)
      from step(3) obtain C us vs where
        *: "s = fill_gholes C us" "t = fill_gholes C vs" and
        l: "num_gholes C = length us" "length us = length vs" and
        inv: "P C" "∀i<length vs. (us ! i, vs ! i) ∈ ℛ"
        by auto
      from step(2) obtain D xs ys where
        **: "t = fill_gholes D xs" "u = fill_gholes D ys" and
        l': "num_gholes D = length xs" "length xs = length ys" and
        inv': "P D" "∀i<length ys. (xs ! i, ys ! i) ∈ ℛ"
        by auto
      let ?C' = "C ⊓ D"
      let ?sss = "unfill_gholes ?C' s" let ?uss = "unfill_gholes ?C' u"
      have less: "?C' ≤ gmctxt_of_gterm s" "?C' ≤ gmctxt_of_gterm u"
        using eq_gfill.intros eqgf_less_eq inf.coboundedI1 inf.coboundedI2 l(1) l'(1)
        unfolding * ** unfolding l'(2)
        by metis+
      from *(2) **(1) have comp: "(C, D) ∈ comp_gmctxt" using l l'
        using eqgf_comp_gmctxt by fastforce
      then have P: "P ?C'" using inv(1) inv'(1) assms(5) by blast
      moreover have l'': "num_gholes ?C' = length ?sss" "length ?sss = length ?uss"
        using less by auto
      moreover have fill: "fill_gholes ?C' ?sss = s" "fill_gholes ?C' ?uss = u"
        using less by (simp add: fill_unfill_gholes)+
      moreover have "∀ i < length ?uss. (?sss ! i, ?uss ! i) ∈ ℛ"
      proof (rule, rule)
        fix i assume i: "i < length (unfill_gholes ?C' u)"
        then obtain p where pos: "p ∈ ghole_poss ?C'"
          "unfill_gholes ?C' s ! i = gsubt_at (fill_gholes ?C' ?sss) p"
          "unfill_gholes ?C' u ! i = gsubt_at (fill_gholes ?C' ?uss) p"
          using fill l'' fill_gholes_ghole_poss
          by (metis eq_gfill.intros ghole_poss_ghole_poss_list_conv length_ghole_poss_list_num_gholes nth_mem)
        from comp_gmctxt_inf_ghole_poss_cases[OF comp pos(1)]
        consider (a) "p ∈ ghole_poss C ∧ p ∈ ghole_poss D" |
                 (b) "p ∈ ghole_poss C ∧ p ∈ poss_gmctxt D" |
                 (c) "p ∈ ghole_poss D ∧ p ∈ poss_gmctxt C" by blast
        then show "(unfill_gholes ?C' s ! i, unfill_gholes ?C' u ! i) ∈ ℛ" unfolding pos fill
        proof cases
          case a
          then show "(gsubt_at s p, gsubt_at u p) ∈ ℛ"
            using assms(1) *(2) l l' inv(2) inv'(2) unfolding * **
            using ghole_poss_nth_subt_at
            by (metis "*"(2) "**"(1) eq_gfill.intros trancl_id trancl_into_trancl2)
        next
          case b
          then have sp: "gsubt_at t p =Gf (subgm_at D p, gmctxt_subtgm_at_fill_args p D xs)"
            "gsubt_at u p =Gf (subgm_at D p, gmctxt_subtgm_at_fill_args p D ys)"
            using poss_gmctxt_fill_gholes_split[of _ D _ p] ** l'
            by force+
          have "(gsubt_at t p, gsubt_at u p) ∈ gmctxtex_onp Q ℛ" using inv'(2)
            using assms(4)[OF inv'(1) conjunct2[OF b]] eqgfE[OF sp(1)] eqgfE[OF sp(2)]
            by (auto simp: gmctxt_subtgm_at_fill_args_def intro!: gmctxtex_onpI)
          moreover have "(gsubt_at s p, gsubt_at t p) ∈ ℛ"
            using * l inv(2)
            using ghole_poss_nth_subt_at[OF _ conjunct1[OF b]]
            by auto (metis eq_gfill.intros)
          ultimately show "(gsubt_at s p, gsubt_at u p) ∈ ℛ"
            using assms(3) by auto
        next
         case c
         then have sp: "gsubt_at s p =Gf (subgm_at C p, gmctxt_subtgm_at_fill_args p C us)"
            "gsubt_at t p =Gf (subgm_at C p, gmctxt_subtgm_at_fill_args p C vs)"
            using poss_gmctxt_fill_gholes_split[of _ C _ p] * l
            by force+
          have "(gsubt_at s p, gsubt_at t p) ∈ gmctxtex_onp Q ℛ" using inv(2)
            using assms(4)[OF inv(1) conjunct2[OF c]] eqgfE[OF sp(1)] eqgfE[OF sp(2)]
            by (auto simp: gmctxt_subtgm_at_fill_args_def intro!: gmctxtex_onpI)
          moreover have "(gsubt_at t p, gsubt_at u p) ∈ ℛ"
            using ** l' inv'(2)
            using ghole_poss_nth_subt_at[OF _ conjunct1[OF c]]
            by auto (metis eq_gfill.intros)
          ultimately show "(gsubt_at s p, gsubt_at u p) ∈ ℛ"
            using assms(2) by auto
        qed
      qed
      ultimately show ?case by (metis gmctxtex_onpI)
    qed simp}
  then show "?Ls ⊆ ?Rs" by auto
qed

subsection ‹Restr to set, union and predicate distribution›

lemma Restr_gctxtex_onp_dist [simp]:
  "Restr (gctxtex_onp P ℛ) (𝒯G ℱ) =
    gctxtex_onp (λ C. funas_gctxt C ⊆ ℱ ∧ P C) (Restr ℛ (𝒯G ℱ))"
  by (auto simp: gctxtex_onp_def 𝒯G_equivalent_def) blast

lemma Restr_gmctxtex_onp_dist [simp]:
  "Restr (gmctxtex_onp P ℛ) (𝒯G ℱ) =
     gmctxtex_onp  (λ C. funas_gmctxt C ⊆ ℱ ∧ P C) (Restr ℛ (𝒯G ℱ))"
  by (auto elim!: gmctxtex_onpE simp: 𝒯G_equivalent_def SUP_le_iff gmctxtex_onpI)
    (metis in_set_idx subsetD)+


lemma Restr_id_subset_gmctxtex_onp [intro]:
  assumes "⋀ C. num_gholes C = 0 ∧ funas_gmctxt C ⊆ ℱ ⟹ P C"
  shows "Restr Id (𝒯G ℱ) ⊆ gmctxtex_onp P ℛ"
proof
  fix s t assume "(s, t) ∈ Restr Id (𝒯G ℱ)"
  then show "(s, t) ∈ gmctxtex_onp P ℛ" using assms[of "gmctxt_of_gterm t"]
    using gmctxtex_onpI[of P "gmctxt_of_gterm t" "[]" "[]" ℛ]
    by (auto simp: 𝒯G_equivalent_def)
qed

lemma Restr_id_subset_gmctxtex_onp2 [intro]:
  assumes "⋀ f n. (f, n) ∈ ℱ ⟹ P (GMFun f (replicate n GMHole))"
   and "⋀ C Ds. num_gholes C = length Ds ⟹ P C ⟹ ∀ D ∈ set Ds. P D ⟹ P (fill_gholes_gmctxt C Ds)"
 shows "Restr Id (𝒯G ℱ) ⊆ gmctxtex_onp P ℛ"
proof
  fix s t assume "(s, t) ∈ Restr Id (𝒯G ℱ)"
  then have *: "s = t" "t ∈ 𝒯G ℱ" by auto
  have "P (gmctxt_of_gterm t)" using *(2)
  proof (induct)
    case (const a)
    show ?case using assms(1)[OF const] by auto
  next
    case (ind f n ss)
    let ?C = "GMFun f (replicate (length ss) GMHole)"
    have "P (fill_gholes_gmctxt ?C (map gmctxt_of_gterm ss))"
      using assms(1)[OF ind(1)] ind
      by (intro assms(2)) (auto simp: in_set_conv_nth)
    then show ?case
      by (metis fill_gholes_gmctxt_GMFun_replicate_length gmctxt_of_gterm.simps length_map) 
  qed
  from gmctxtex_onpI[of P, OF this] show "(s, t) ∈ gmctxtex_onp P ℛ" unfolding *
    by auto
qed


lemma gctxtex_onp_union [simp]:
  "gctxtex_onp P (ℛ ∪ ℒ) = gctxtex_onp P ℛ ∪ gctxtex_onp P ℒ"
  by auto

lemma gctxtex_onp_pred_dist:
  assumes "⋀ C. P C ⟷ Q C ∨ R C"
  shows "gctxtex_onp P ℛ = gctxtex_onp Q ℛ ∪ gctxtex_onp R ℛ"
  using assms by auto fastforce

lemma gmctxtex_onp_pred_dist:
  assumes "⋀ C. P C ⟷ Q C ∨ R C"
  shows "gmctxtex_onp P ℛ = gmctxtex_onp Q ℛ ∪ gmctxtex_onp R ℛ"
  using assms by (auto elim!: gmctxtex_onpE)

lemma trivial_gctxtex_onp [simp]: "gctxtex_onp (λ C. C = □G) ℛ = ℛ"
  using gctxtex_closure by force

lemma trivial_gmctxtex_onp [simp]: "gmctxtex_onp (λ C. C = GMHole) ℛ = ℛ"
proof
  show "gmctxtex_onp (λC. C = GMHole) ℛ ⊆ ℛ"
    by (auto elim!: gmctxtex_onpE) force
next
  show "ℛ ⊆ gmctxtex_onp (λC. C = GMHole) ℛ"
    by (intro gmctxtex_closure) auto
qed

subsection ‹Distribution of context closures over relation composition›

lemma gctxtex_onp_relcomp_inner:
  "gctxtex_onp P (ℛ O ℒ) ⊆ gctxtex_onp P ℛ O gctxtex_onp P ℒ"
  by auto

lemma gmctxtex_onp_relcomp_inner:
  "gmctxtex_onp P (ℛ O ℒ) ⊆ gmctxtex_onp P ℛ O gmctxtex_onp P ℒ"
proof
  fix s t
  assume "(s, t) ∈ gmctxtex_onp P (ℛ O ℒ)"
  from gmctxtex_onpE[OF this] obtain C us vs where
    *: "s = fill_gholes C us" "t = fill_gholes C vs" and
    len: "num_gholes C = length us" "length us = length vs" and
    inv: "P C" "∀ i < length vs. (us ! i, vs ! i) ∈ ℛ O ℒ" by blast
  obtain zs where l: "length vs = length zs" and
    rel: "∀ i < length zs. (us ! i, zs ! i) ∈ ℛ" "∀ i < length zs. (zs ! i, vs ! i) ∈ ℒ"
    using len(2) inv(2) Ex_list_of_length_P[of _ "λ y i. (us ! i, y) ∈ ℛ ∧ (y, vs ! i) ∈ ℒ"]
    by (auto simp: relcomp_unfold) metis
  from len l rel inv have "(s, fill_gholes C zs) ∈ gmctxtex_onp P ℛ" unfolding *
    by auto
  moreover from len l rel inv have "(fill_gholes C zs, t) ∈ gmctxtex_onp P ℒ" unfolding *
    by auto
  ultimately show "(s, t) ∈ gmctxtex_onp P ℛ O gmctxtex_onp P ℒ"
    by auto
qed

subsection ‹Signature preserving and signature closed›

definition function_closed where
  "function_closed ℱ ℛ ⟷ (∀ f ss ts. (f, length ts) ∈ ℱ ⟶ 0 ≠ length ts ⟶
    length ss = length ts ⟶ (∀ i. i < length ts ⟶ (ss ! i, ts ! i) ∈ ℛ) ⟶
    (GFun f ss, GFun f ts) ∈ ℛ)"

lemma function_closedD: "function_closed ℱ ℛ ⟹
  (f,length ts) ∈ ℱ ⟹ 0 ≠ length ts ⟹ length ss = length ts ⟹
  ⟦⋀ i. i < length ts ⟹ (ss ! i, ts ! i) ∈ ℛ⟧ ⟹
  (GFun f ss, GFun f ts) ∈ ℛ"
  unfolding function_closed_def by blast

lemma all_ctxt_closed_imp_function_closed:
  "all_ctxt_closed ℱ ℛ ⟹ function_closed ℱ ℛ"
  unfolding all_ctxt_closed_def function_closed_def
  by auto

lemma all_ctxt_closed_imp_reflx_on_sig:
  assumes "all_ctxt_closed ℱ ℛ"
  shows "Restr Id (𝒯G ℱ) ⊆ ℛ"
proof -
  {fix s assume "(s, s) ∈ Restr Id (𝒯G ℱ)" then have "(s, s) ∈ ℛ"
    proof (induction s)
      case (GFun f ts)
      then show ?case using all_ctxt_closedD[OF assms]
        by (auto simp: 𝒯G_equivalent_def UN_subset_iff)
    qed}
  then show ?thesis by auto
qed

lemma function_closed_un_id_all_ctxt_closed:
  "function_closed ℱ ℛ ⟹ Restr Id (𝒯G ℱ) ⊆ ℛ ⟹ all_ctxt_closed ℱ ℛ"
  unfolding all_ctxt_closed_def
  by (auto dest: function_closedD simp: subsetD)

lemma gctxtex_onp_in_signature [intro]:
  assumes "⋀ C. P C ⟹ funas_gctxt C ⊆ ℱ" "⋀ C. P C ⟹ funas_gctxt C ⊆ 𝒢"
    and "ℛ ⊆ 𝒯G ℱ × 𝒯G 𝒢"
  shows "gctxtex_onp P ℛ ⊆ 𝒯G ℱ × 𝒯G 𝒢" using assms
  by (auto simp: gctxtex_onp_def 𝒯G_equivalent_def) blast+

lemma gmctxtex_onp_in_signature [intro]:
  assumes "⋀ C. P C ⟹ funas_gmctxt C ⊆ ℱ" "⋀ C. P C ⟹ funas_gmctxt C ⊆ 𝒢"
    and "ℛ ⊆ 𝒯G ℱ × 𝒯G 𝒢"
  shows "gmctxtex_onp P ℛ ⊆ 𝒯G ℱ × 𝒯G 𝒢" using assms
  by (auto simp: gmctxtex_onp_def 𝒯G_equivalent_def in_set_conv_nth) force+

lemma gctxtex_onp_in_signature_tranc [intro]:
  "gctxtex_onp P ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ ⟹ (gctxtex_onp P ℛ)+ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  by (auto simp: Restr_simps)

lemma gmctxtex_onp_in_signature_tranc [intro]:
  "gmctxtex_onp P ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ ⟹ (gmctxtex_onp P ℛ)+ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  by (auto simp: Restr_simps)

lemma gmctxtex_onp_fun_closed [intro!]:
  assumes "⋀ f n. (f, n) ∈ ℱ ⟹ n ≠ 0 ⟹ P (GMFun f (replicate n GMHole))"
    and "⋀ C Ds. P C ⟹ num_gholes C = length Ds ⟹ 0 < num_gholes C ⟹
      ∀ D ∈ set Ds. P D ⟹ P (fill_gholes_gmctxt C Ds)"
  shows "function_closed ℱ (gmctxtex_onp P ℛ)" unfolding function_closed_def
proof (rule allI, intro allI, intro impI)
  fix f ss ts assume sig: "(f, length ts) ∈ ℱ"
    and len: "0 ≠ length ts" "length ss = length ts"
    and mem: "∀ i < length ts. (ss ! i, ts ! i) ∈ gmctxtex_onp P ℛ"
  let ?C = "GMFun f (replicate (length ts) GMHole)"
  from mem len obtain Ds sss tss where
    l': "length ts = length Ds" "length Ds = length sss" "length sss = length tss" and
    inn: "∀ i < length tss. length (sss ! i) = length (tss ! i)" and
    eq: "∀ i < length tss. ss ! i =Gf (Ds ! i, sss ! i)" "∀ i < length tss. ts ! i =Gf (Ds ! i, tss ! i)" and
    inv: "∀ i < length (concat tss). (concat sss ! i, concat tss ! i) ∈ ℛ" "∀ D ∈ set Ds. P D"
    by (auto elim!: gmctxtex_onp_listE)
  have *: "fill_gholes ?C ss = GFun f ss" "fill_gholes ?C ts = GFun f ts"
    using len assms(1) by (auto simp del: fill_gholes.simps)
  have s: "GFun f ss =Gf (fill_gholes_gmctxt ?C Ds, concat sss)"
    using assms(1) l' eq(1) inn len inv(1) unfolding *[symmetric]
    by (intro fill_gholes_gmctxt_sound) auto
  have t: "GFun f ts =Gf (fill_gholes_gmctxt ?C Ds, concat tss)"
    using assms(1) eq l' inn len inv(1) unfolding *[symmetric]
    by (intro fill_gholes_gmctxt_sound) auto
  then show "(GFun f ss, GFun f ts) ∈ gmctxtex_onp P ℛ"
    unfolding eqgfE[OF s] eqgfE[OF t]
    using eqgfE(2)[OF s] eqgfE(2)[OF t] sig len l' inv
    using assms(1)[OF sig] assms(2)[of "GMFun f (replicate (length ts) GMHole)" Ds]
    using gmctxtex_onpI[of P "fill_gholes_gmctxt (GMFun f (replicate (length ts) GMHole)) Ds" "concat sss" "concat tss" ℛ]
    by (auto simp del: fill_gholes_gmctxt.simps fill_gholes.simps)
qed

declare subsetI[rule del]
lemma gmctxtex_onp_sig_closed [intro]:
  assumes "⋀ f n. (f, n) ∈ ℱ ⟹ P (GMFun f (replicate n GMHole))"
    and  "⋀ C Ds. num_gholes C = length Ds ⟹ P C ⟹ ∀ D ∈ set Ds. P D ⟹ P (fill_gholes_gmctxt C Ds)"
  shows "all_ctxt_closed ℱ (gmctxtex_onp P ℛ)" using assms
  by (intro function_closed_un_id_all_ctxt_closed) auto
declare subsetI[intro!]

lemma gmctxt_cl_gmctxtex_onp_conv:
  "gmctxt_cl ℱ ℛ = gmctxtex_onp (λ C. funas_gmctxt C ⊆ ℱ) ℛ" (is "?Ls = ?Rs")
proof -
  have sig_cl: "all_ctxt_closed ℱ (?Rs)" by (intro gmctxtex_onp_sig_closed) auto
  {fix s t assume "(s, t) ∈ ?Ls" then have "(s, t) ∈ ?Rs"
    proof induct
      case (step ss ts f)
      then show ?case using all_ctxt_closedD[OF sig_cl]
        by force
    qed (intro subsetD[OF gmctxtex_onp_arg_monoI], auto)}
  moreover
  {fix s t assume "(s, t) ∈ ?Rs"
    from gmctxtex_onpE[OF this] obtain C us vs where
      terms: "s = fill_gholes C us" "t = fill_gholes C vs" and
      fill_inv: "num_gholes C = length us" "length us = length vs" and
      rel: "funas_gmctxt C ⊆ ℱ" "∀ i < length vs. (us ! i, vs ! i) ∈ ℛ" by blast
    have "(s, t) ∈ ?Ls" unfolding terms using fill_inv rel
    proof (induct C arbitrary: us vs)
      case GMHole
      then show ?case using rel(2) by (cases vs; cases us) auto
    next
      case (GMFun f Ds)
      show ?case using GMFun(2-) unfolding partition_holes_fill_gholes_conv'
        by (intro all_ctxt_closedD[OF gmctxt_cl_is_all_ctxt_closed[of ℱ ℛ]])
           (auto simp: partition_by_nth_nth SUP_le_iff length_partition_gholes_nth intro!: GMFun(1))
    qed}
  ultimately show ?thesis by auto
qed

end

Theory FOR_Certificate

theory FOR_Certificate
  imports Rewriting
begin

section ‹Certificate syntax and type declarations›

type_alias fvar = nat              ― ‹variable id›
datatype ftrs = Fwd nat | Bwd nat  ― ‹TRS id and direction›

definition map_ftrs where
  "map_ftrs f = case_ftrs (Fwd ∘ f) (Bwd ∘ f)"

subsection ‹GTT relations›

(* note: the 'trs will always be trs, but this way we get map functions for free *)

datatype 'trs gtt_rel                    ― ‹GTT relations›
  = ARoot "'trs list"                    ― ‹root steps›
  | GInv "'trs gtt_rel"                  ― ‹inverse of anchored or ordinary GTT relation›
  | AUnion "'trs gtt_rel" "'trs gtt_rel" ― ‹union of anchored GTT relation›
  | ATrancl "'trs gtt_rel"               ― ‹transitive closure of anchored GTT relation›
  | GTrancl "'trs gtt_rel"               ― ‹transitive closure of ordinary GTT relation›
  | AComp "'trs gtt_rel" "'trs gtt_rel"  ― ‹composition of anchored GTT relations›
  | GComp "'trs gtt_rel" "'trs gtt_rel"  ― ‹composition of ordinary GTT relations›

(* derived constructs *)
definition GSteps where "GSteps trss = GTrancl (ARoot trss)"


subsection ‹RR1 and RR2 relations›

datatype pos_step ― ‹position specification for lifting anchored GTT relation›
  = PRoot         ― ‹allow only root steps›
  | PNonRoot      ― ‹allow only non-root steps›
  | PAny          ― ‹allow any position›

datatype ext_step   ― ‹kind of rewrite steps for lifting anchored GTT relation›
  = ESingle         ― ‹single steps›
  | EParallel       ― ‹parallel steps, allowing the empty step›
  | EStrictParallel ― ‹parallel steps, no allowing the empty step›

datatype 'trs rr1_rel                     ― ‹RR1 relations, aka regular tree languages›
  = R1Terms                               ― ‹all terms as RR1 relation (regular tree languages)›
  | R1NF "'trs list"                      ― ‹direct normal form construction wrt. single steps›
  | R1Inf "'trs rr2_rel"                  ― ‹infiniteness predicate›
  | R1Proj nat "'trs rr2_rel"             ― ‹projection of RR2 relation›
  | R1Union "'trs rr1_rel" "'trs rr1_rel" ― ‹union of RR1 relations›
  | R1Inter "'trs rr1_rel" "'trs rr1_rel" ― ‹intersection of RR1 relations›
  | R1Diff "'trs rr1_rel" "'trs rr1_rel"  ― ‹difference of RR1 relations›
and 'trs rr2_rel                          ― ‹RR2 relations›
  = R2GTT_Rel "'trs gtt_rel" pos_step ext_step ― ‹lifted GTT relations›
  | R2Diag "'trs rr1_rel"                 ― ‹diagonal relation›
  | R2Prod "'trs rr1_rel" "'trs rr1_rel"  ― ‹Cartesian product›
  | R2Inv "'trs rr2_rel"                  ― ‹inverse of RR2 relation›
  | R2Union "'trs rr2_rel" "'trs rr2_rel" ― ‹union of RR2 relations›
  | R2Inter "'trs rr2_rel" "'trs rr2_rel" ― ‹intersection of RR2 relations›
  | R2Diff "'trs rr2_rel" "'trs rr2_rel"  ― ‹difference of RR2 relations›
  | R2Comp "'trs rr2_rel" "'trs rr2_rel"  ― ‹composition of RR2 relations›

(* derived constructs *)
definition R1Fin where                    ― ‹finiteness predicate›
  "R1Fin r = R1Diff R1Terms (R1Inf r)"
definition R2Eq where                     ― ‹equality›
  "R2Eq = R2Diag R1Terms"
definition R2Reflc where                  ― ‹reflexive closure›
  "R2Reflc r = R2Union r R2Eq"
definition R2Step where                   ― ‹single step $\to$›
  "R2Step trss = R2GTT_Rel (ARoot trss) PAny ESingle"
definition R2StepEq where                 ― ‹at most one step $\to^=$›
  "R2StepEq trss = R2Reflc (R2Step trss)"
definition R2Steps where                  ― ‹at least one step $\to^+$›
  "R2Steps trss = R2GTT_Rel (GSteps trss) PAny EStrictParallel"
definition R2StepsEq where                ― ‹many steps $\to^*$›
  "R2StepsEq trss = R2GTT_Rel (GSteps trss) PAny EParallel"
definition R2StepsNF where                ― ‹rewrite to normal form $\to^!$›
  "R2StepsNF trss = R2Inter (R2StepsEq trss) (R2Prod R1Terms (R1NF trss))"
definition R2ParStep where                ― ‹parallel step›
  "R2ParStep trss = R2GTT_Rel (ARoot trss) PAny EParallel"
definition R2RootStep where               ― ‹root step $\to_\epsilon$›
  "R2RootStep trss = R2GTT_Rel (ARoot trss) PRoot ESingle"
definition R2RootStepEq where             ― ‹at most one root step $\to_\epsilon^=$›
  "R2RootStepEq trss = R2Reflc (R2RootStep trss)"
  (* alternatively R2GTT_Rel (ARoot trss) PRoot SParallel *)
definition R2RootSteps where              ― ‹at least one root step $\to_\epsilon^+$›
  "R2RootSteps trss = R2GTT_Rel (ATrancl (ARoot trss)) PRoot ESingle"
definition R2RootStepsEq where            ― ‹many root steps $\to_\epsilon^*$›
  "R2RootStepsEq trss = R2Reflc (R2RootSteps trss)"
definition R2NonRootStep where            ― ‹non-root step $\to_{>\epsilon}$›
  "R2NonRootStep trss = R2GTT_Rel (ARoot trss) PNonRoot ESingle"
definition R2NonRootStepEq where          ― ‹at most one non-root step $\to_{>\epsilon}^=$›
  "R2NonRootStepEq trss = R2Reflc (R2NonRootStep trss)"
definition R2NonRootSteps where           ― ‹at least one non-root step $\to_{>\epsilon}^+$›
  "R2NonRootSteps trss = R2GTT_Rel (GSteps trss) PNonRoot EStrictParallel"
definition R2NonRootStepsEq where         ― ‹many non-root steps $\to_{>\epsilon}^*$›
  "R2NonRootStepsEq trss = R2GTT_Rel (GSteps trss) PNonRoot EParallel"
definition R2Meet where                   ― ‹meet $\uparrow$›
  "R2Meet trss = R2GTT_Rel (GComp (GInv (GSteps trss)) (GSteps trss)) PAny EParallel"
definition R2Join where                   ― ‹join $\downarrow$›
  "R2Join trss = R2GTT_Rel (GComp (GSteps trss) (GInv (GSteps trss))) PAny EParallel"


subsection ‹Formulas›

datatype 'trs formula             ― ‹formulas›
  = FRR1 "'trs rr1_rel" fvar      ― ‹application of RR1 relation›
  | FRR2 "'trs rr2_rel" fvar fvar ― ‹application of RR2 relation›
  | FAnd "('trs formula) list"    ― ‹conjunction›
  | FOr "('trs formula) list"     ― ‹disjunction›
  | FNot "'trs formula"           ― ‹negation›
  | FExists "'trs formula"        ― ‹existential quantification›
  | FForall "'trs formula"        ― ‹universal quantification›

(* derived constructs *)
definition FTrue where            ― ‹true›
  "FTrue ≡ FAnd []"
definition FFalse where           ― ‹false›
  "FFalse ≡ FOr []"
(* FRestrict can be defined, but we may want to do out of bounds checking later *)
definition FRestrict where      ― ‹reorder/rename/restrict TRSs for subformula›
  "FRestrict f trss ≡ map_formula (map_ftrs (λn. if n ≥ length trss then 0 else trss ! n)) f"


subsection ‹Signatures and Problems›

datatype ('f, 'v, 't) many_sorted_sig
  = Many_Sorted_Sig (ms_functions: "('f × 't list × 't) list") (ms_variables: "('v × 't) list")

datatype ('f, 'v, 't) problem
  = Problem (p_signature: "('f, 'v, 't) many_sorted_sig")
            (p_trss: "('f, 'v) trs list")
            (p_formula: "ftrs formula")


subsection ‹Proofs›

datatype equivalence ― ‹formula equivalences›
  = EDistribAndOr    ― ‹distributivity: conjunction over disjunction›
  | EDistribOrAnd    ― ‹distributivity: disjunction over conjunction›

datatype 'trs inference           ― ‹inference rules for formula creation›
  = IRR1 "'trs rr1_rel" fvar      ― ‹formula from RR1 relation›
  | IRR2 "'trs rr2_rel" fvar fvar ― ‹formula from RR2 relation›
  | IAnd "nat list"               ― ‹conjunction›
  | IOr "nat list"                ― ‹disjunction›
  | INot nat                      ― ‹negation›
  | IExists nat                   ― ‹existential quantification›
  | IRename nat "fvar list"       ― ‹permute variables›
  | INNFPlus nat                  ― ‹equivalence modulo negation normal form plus ACIU0 for $\land$ and $\lor$›
  | IRepl equivalence "nat list" nat ― ‹replacement according to given equivalence›

datatype claim = Empty | Nonempty

datatype info = Size nat nat nat

datatype 'trs certificate
  = Certificate "(nat × 'trs inference × 'trs formula × info list) list" claim nat


subsection ‹Example›

definition no_normal_forms_cert :: "ftrs certificate" where
  "no_normal_forms_cert = Certificate
  [ (0, (IRR2 (R2Step [Fwd 0]) 1 0),
        (FRR2 (R2Step [Fwd 0]) 1 0), [])
  , (1, (IExists 0),
        (FExists (FRR2 (R2Step [Fwd 0]) 1 0)), [])
  , (2, (INot 1),
        (FNot (FExists (FRR2 (R2Step [Fwd 0]) 1 0))), [])
  , (3, (IExists 2),
        (FExists (FNot (FExists (FRR2 (R2Step [Fwd 0]) 1 0)))), [])
  , (4, (INot 3),
        (FNot (FExists (FNot (FExists (FRR2 (R2Step [Fwd 0]) 1 0))))), [])
  , (5, (INNFPlus 4),
        (FForall (FExists (FRR2 (R2Step [Fwd 0]) 1 0))), [])
  ] Nonempty 5"

definition no_normal_forms_problem :: "(string, string, unit) problem" where
  "no_normal_forms_problem = Problem
    (Many_Sorted_Sig [(''f'',[()],()), (''a'',[],())] [(''x'',())])
    [{(Fun ''f'' [Var ''x''],Fun ''a'' [])}]
    (FForall (FExists (FRR2 (R2Step [Fwd 0]) 1 0)))"

end
body>

Theory Lift_Root_Step

section ‹Lifting root steps to single/parallel root/non-root steps›
theory Lift_Root_Step
  imports
    Rewriting
    FOR_Certificate
    Context_Extensions
    Multihole_Context
begin

text ‹Closure under all contexts›
abbreviation "gctxtcl ℛ ≡ gctxtex_onp (λ C. True) ℛ"
abbreviation "gmctxtcl ℛ ≡ gctxtex_onp (λ C. True) ℛ"

text ‹Extension under all non empty contexts›
abbreviation "gctxtex_nempty ℛ ≡ gctxtex_onp (λ C. C ≠ □G) ℛ"
abbreviation "gmctxtex_nempty ℛ ≡ gmctxtex_onp (λ C. C ≠ GMHole) ℛ"

text ‹Closure under all contexts respecting the signature›
abbreviation "gctxtcl_funas ℱ ℛ ≡ gctxtex_onp (λ C. funas_gctxt C ⊆ ℱ) ℛ"
abbreviation "gmctxtcl_funas ℱ ℛ ≡ gmctxtex_onp (λ C. funas_gmctxt C ⊆ ℱ) ℛ"

text ‹Closure under all multihole contexts with at least one hole respecting the signature›
abbreviation "gmctxtcl_funas_strict ℱ ℛ ≡ gmctxtex_onp (λ C. 0 < num_gholes C ∧ funas_gmctxt C ⊆ ℱ) ℛ"

text ‹Extension under all non empty contexts respecting the signature›
abbreviation "gctxtex_funas_nroot ℱ ℛ ≡ gctxtex_onp (λ C. funas_gctxt C ⊆ ℱ ∧ C ≠ □G) ℛ"
abbreviation "gmctxtex_funas_nroot ℱ ℛ ≡ gmctxtex_onp (λ C. funas_gmctxt C ⊆ ℱ ∧ C ≠ GMHole) ℛ"

text ‹Extension under all non empty contexts respecting the signature›
abbreviation "gmctxtex_funas_nroot_strict ℱ ℛ ≡
   gmctxtex_onp (λ C.  0 < num_gholes C ∧ funas_gmctxt C ⊆ ℱ ∧ C ≠ GMHole) ℛ"


subsection ‹Rewrite steps equivalent definitions›

definition gsubst_cl :: "('f, 'v) trs ⇒ 'f gterm rel" where
  "gsubst_cl ℛ = {(gterm_of_term (l ⋅ σ), gterm_of_term (r ⋅ σ)) |
    l r (σ :: 'v ⇒ ('f, 'v) Term.term). (l, r) ∈ ℛ ∧ ground (l ⋅ σ) ∧ ground (r ⋅ σ)}"

definition gnrrstepD :: "'f sig ⇒ 'f gterm rel ⇒ 'f gterm rel" where
  "gnrrstepD ℱ ℛ = gctxtex_funas_nroot ℱ ℛ"

definition grstepD :: "'f sig ⇒ 'f gterm rel ⇒ 'f gterm rel" where
  "grstepD ℱ ℛ = gctxtcl_funas ℱ ℛ"

definition gpar_rstepD :: "'f sig ⇒ 'f gterm rel ⇒ 'f gterm rel" where
  "gpar_rstepD ℱ ℛ = gmctxtcl_funas ℱ ℛ"

inductive_set gpar_rstepD' :: "'f sig ⇒ 'f gterm rel ⇒ 'f gterm rel" for ℱ :: "'f sig" and ℛ :: "'f gterm rel"
  where groot_step [intro]: "(s, t) ∈ ℛ ⟹ (s, t) ∈ gpar_rstepD' ℱ ℛ"
     |  gpar_step_fun [intro]: "⟦⋀ i. i < length ts ⟹ (ss ! i, ts ! i) ∈ gpar_rstepD' ℱ ℛ⟧ ⟹ length ss = length ts
             ⟹ (f, length ts) ∈ ℱ ⟹ (GFun f ss, GFun f ts) ∈ gpar_rstepD' ℱ ℛ"

subsection ‹Interface between rewrite step definitions and sets›

fun lift_root_step :: "('f × nat) set ⇒ pos_step ⇒ ext_step ⇒ 'f gterm rel ⇒ 'f gterm rel" where
  "lift_root_step ℱ PAny ESingle ℛ = gctxtcl_funas ℱ ℛ"
| "lift_root_step ℱ PAny EStrictParallel ℛ = gmctxtcl_funas_strict ℱ ℛ"
| "lift_root_step ℱ PAny EParallel ℛ = gmctxtcl_funas ℱ ℛ"
| "lift_root_step ℱ PNonRoot ESingle ℛ = gctxtex_funas_nroot ℱ ℛ"
| "lift_root_step ℱ PNonRoot EStrictParallel ℛ = gmctxtex_funas_nroot_strict ℱ ℛ"
| "lift_root_step ℱ PNonRoot EParallel ℛ = gmctxtex_funas_nroot ℱ ℛ"
| "lift_root_step ℱ PRoot ESingle ℛ = ℛ"
| "lift_root_step ℱ PRoot EStrictParallel ℛ = ℛ"
| "lift_root_step ℱ PRoot EParallel ℛ = ℛ ∪ Restr Id (𝒯G ℱ)"

subsection ‹Compatibility of used predicate extensions and signature closure›

lemma compatible_p [simp]:
  "compatible_p (λ C. C ≠ □G) (λ C. C ≠ GMHole)"
  "compatible_p (λ C. funas_gctxt C ⊆ ℱ) (λ C. funas_gmctxt C ⊆ ℱ)"
  "compatible_p (λ C. funas_gctxt C ⊆ ℱ ∧ C ≠ □G) (λ C. funas_gmctxt C ⊆ ℱ ∧ C ≠ GMHole)"
  unfolding compatible_p_def
  by rule (case_tac C, auto)+

lemma gmctxtcl_funas_sigcl:
  "all_ctxt_closed ℱ (gmctxtcl_funas ℱ ℛ)"
  by (intro gmctxtex_onp_sig_closed) auto

lemma gctxtex_funas_nroot_sigcl:
  "all_ctxt_closed ℱ (gmctxtex_funas_nroot ℱ ℛ)"
  by (intro gmctxtex_onp_sig_closed) auto

lemma gmctxtcl_funas_strict_funcl:
  "function_closed ℱ (gmctxtcl_funas_strict ℱ ℛ)"
  by (intro gmctxtex_onp_fun_closed) (auto dest: list.set_sel)

lemma gmctxtex_funas_nroot_strict_funcl:
  "function_closed ℱ (gmctxtex_funas_nroot_strict ℱ ℛ)"
  by (intro gmctxtex_onp_fun_closed) (auto dest: list.set_sel)

lemma gctxtcl_funas_dist:
  "gctxtcl_funas ℱ ℛ = gctxtex_onp (λ C. C = □G) ℛ ∪ gctxtex_funas_nroot ℱ ℛ"
  by (intro gctxtex_onp_pred_dist) auto

lemma gmctxtex_funas_nroot_dist:
  "gmctxtex_funas_nroot ℱ ℛ = gmctxtex_funas_nroot_strict ℱ ℛ ∪
     gmctxtex_onp (λ C. num_gholes C = 0 ∧ funas_gmctxt C ⊆ ℱ) ℛ"
  by (intro gmctxtex_onp_pred_dist) auto

lemma gmctxtcl_funas_dist:
  "gmctxtcl_funas ℱ ℛ = gmctxtex_onp (λ C. num_gholes C = 0 ∧ funas_gmctxt C ⊆ ℱ) ℛ ∪
     gmctxtex_onp (λ C. 0 < num_gholes C ∧ funas_gmctxt C ⊆ ℱ) ℛ"
  by (intro gmctxtex_onp_pred_dist) auto

lemma gmctxtcl_funas_strict_dist:
  "gmctxtcl_funas_strict ℱ ℛ = gmctxtex_funas_nroot_strict ℱ ℛ ∪ gmctxtex_onp (λ C. C = GMHole) ℛ"
  by (intro gmctxtex_onp_pred_dist) auto

lemma gmctxtex_onpzero_num_gholes_id [simp]:
  "gmctxtex_onp (λ C. num_gholes C = 0 ∧ funas_gmctxt C ⊆ ℱ) ℛ = Restr Id (𝒯G ℱ)" (is "?Ls = ?Rs")
proof -
  {fix s t assume "(s, t) ∈ ?Ls" from gmctxtex_onpE[OF this] obtain C us vs where
    *: "s = fill_gholes C us" "t = fill_gholes C vs" and
    len: "num_gholes C = length us" "length us = length vs" and
    inv: "num_gholes C = 0 ∧ funas_gmctxt C ⊆ ℱ" by auto
    then have "(s, t) ∈ ?Rs" using len inv unfolding *
      by (cases us; cases vs) (auto simp: 𝒯G_funas_gterm_conv)}
  moreover have "?Rs ⊆ ?Ls"
    by (intro Restr_id_subset_gmctxtex_onp) auto
  ultimately show ?thesis by auto
qed

lemma gctxtex_onp_sign_trans_fst:
  assumes "(s, t) ∈ gctxtex_onp P R" and "s ∈ 𝒯G ℱ"
  shows "(s, t) ∈ gctxtex_onp (λ C. funas_gctxt C ⊆ ℱ ∧ P C) R"
  using assms
  by (auto simp: 𝒯G_equivalent_def elim!: gctxtex_onpE)

lemma gctxtex_onp_sign_trans_snd:
  assumes "(s, t) ∈ gctxtex_onp P R" and "t ∈ 𝒯G ℱ"
  shows "(s, t) ∈ gctxtex_onp (λ C. funas_gctxt C ⊆ ℱ ∧ P C) R"
  using assms
  by (auto simp: 𝒯G_equivalent_def elim!: gctxtex_onpE)

lemma gmctxtex_onp_sign_trans_fst:
  assumes "(s, t) ∈ gmctxtex_onp P R" and "s ∈ 𝒯G ℱ"
  shows "(s, t) ∈ gmctxtex_onp (λ C. P C ∧ funas_gmctxt C ⊆ ℱ) R"
  using assms
  by (auto simp: 𝒯G_equivalent_def simp add: gmctxtex_onpI)

lemma gmctxtex_onp_sign_trans_snd:
  assumes "(s, t) ∈ gmctxtex_onp P R" and "t ∈ 𝒯G ℱ"
  shows "(s, t) ∈ gmctxtex_onp (λ C. P C ∧ funas_gmctxt C ⊆ ℱ) R"
  using assms
  by (auto simp: 𝒯G_equivalent_def simp add: gmctxtex_onpI)

subsection ‹Basic lemmas›

lemma gsubst_cl:
  fixes ℛ :: "('f, 'v) trs" and σ :: "'v ⇒ ('f, 'v) term"
  assumes "(l, r) ∈ ℛ" and "ground (l ⋅ σ)" "ground (r ⋅ σ)"
  shows "(gterm_of_term (l ⋅ σ), gterm_of_term (r ⋅ σ)) ∈ gsubst_cl ℛ"
  using assms unfolding gsubst_cl_def by auto

lemma grstepD [simp]:
  "(s, t) ∈ ℛ ⟹ (s, t) ∈ grstepD ℱ ℛ"
  by (auto simp: grstepD_def gctxtex_onp_def intro!: exI[of _ "□G"])

lemma grstepD_ctxtI [intro]:
  "(l, r) ∈ ℛ ⟹ funas_gctxt C ⊆ ℱ ⟹ (C⟨l⟩G, C⟨r⟩G) ∈ grstepD ℱ ℛ"
  by (auto simp: grstepD_def gctxtex_onp_def intro!: exI[of _ "C"])

lemma gctxtex_funas_nroot_gctxtcl_funas_subseteq:
  "gctxtex_funas_nroot ℱ (grstepD ℱ ℛ) ⊆ grstepD ℱ ℛ"
  unfolding grstepD_def
  by (intro gctxtex_pred_cmp_subseteq) auto

lemma Restr_gnrrstepD_dist [simp]:
  "Restr (gnrrstepD ℱ ℛ) (𝒯G 𝒢) = gnrrstepD (ℱ ∩ 𝒢) (Restr ℛ (𝒯G 𝒢))"
  by (auto simp add: gnrrstepD_def)

lemma Restr_grstepD_dist [simp]:
  "Restr (grstepD ℱ ℛ) (𝒯G 𝒢) = grstepD (ℱ ∩ 𝒢) (Restr ℛ (𝒯G 𝒢))"
  by (auto simp add: grstepD_def)

lemma Restr_gpar_rstepD_dist [simp]:
  "Restr (gpar_rstepD ℱ ℛ) (𝒯G 𝒢) = gpar_rstepD (ℱ ∩ 𝒢) (Restr ℛ (𝒯G 𝒢))" (is "?Ls = ?Rs")
  by (auto simp: gpar_rstepD_def)

subsection ‹Equivalence lemmas›

lemma grrstep_subst_cl_conv:
  "grrstep ℛ = gsubst_cl ℛ"
  unfolding gsubst_cl_def grrstep_def rrstep_def rstep_r_p_s_def
  by (auto, metis ground_substI ground_term_of_gterm term_of_gterm_inv) blast

lemma gnrrstepD_gnrrstep_conv:
  "gnrrstep ℛ = gnrrstepD UNIV (gsubst_cl ℛ)" (is "?Ls = ?Rs")
proof -
  {fix s t assume "(s, t) ∈ ?Ls" then obtain l r C σ where
      mem: "(l, r) ∈ ℛ" "C ≠ □" "term_of_gterm s = C⟨l ⋅ (σ :: 'b ⇒ ('a, 'b) term)⟩" "term_of_gterm t = C⟨r ⋅ σ⟩"
      unfolding gnrrstep_def inv_image_def nrrstep_def' by auto
    then have "(s, t) ∈ ?Rs" using gsubst_cl[OF mem(1)]
      using gctxtex_onpI[of "λ C. funas_gctxt C ⊆ UNIV ∧ C ≠ □G" "gctxt_of_ctxt C" "gterm_of_term (l ⋅ σ)"
        "gterm_of_term (r ⋅ σ)" "gsubst_cl ℛ"]
      by (auto simp: gnrrstepD_def)}
  moreover
  {fix s t assume "(s, t) ∈ ?Rs" then have "(s, t) ∈ ?Ls"
      unfolding gnrrstepD_def gctxtex_onp_def gnrrstep_def inv_image_def nrrstep_def' gsubst_cl_def
      by auto (metis ctxt_of_gctxt.simps(1) ctxt_of_gctxt_inv ground_ctxt_of_gctxt ground_gctxt_of_ctxt_apply ground_substI)}
  ultimately show ?thesis by auto
qed

lemma grstepD_grstep_conv:
  "grstep ℛ = grstepD UNIV (gsubst_cl ℛ)" (is "?Ls = ?Rs")
proof -
  {fix s t assume "(s, t) ∈ ?Ls" then obtain C l r σ where
    mem: "(l, r) ∈ ℛ" "term_of_gterm s = C⟨l ⋅ (σ :: 'b ⇒ ('a, 'b) term)⟩" "term_of_gterm t = C⟨r ⋅ σ⟩"
      unfolding grstep_def inv_image_def by auto
    then have "(s, t) ∈ ?Rs" using grstepD_ctxtI[OF gsubst_cl[OF mem(1)], of σ "gctxt_of_ctxt C" UNIV]
      by (auto simp: grstepD_def gctxtex_onp_def)}
  moreover
  {fix s t assume "(s, t) ∈ ?Rs" then have "(s, t) ∈ ?Ls"
      by (auto simp: gctxtex_onp_def grstepD_def grstep_def gsubst_cl_def)
       (metis ctxt_of_gctxt_apply_gterm ground_ctxt_apply
        ground_ctxt_of_gctxt ground_substI gterm_of_term_inv rstep.intros)}
  ultimately show ?thesis by auto
qed

lemma gpar_rstep_gpar_rstepD_conv:
  "gpar_rstep ℛ = gpar_rstepD' UNIV (gsubst_cl ℛ)" (is "?Ls = ?Rs")
proof -
  {fix s t assume "(s, t) ∈ ?Rs"
    then have "(s, t) ∈ gpar_rstep ℛ"
      by induct (auto simp: gpar_rstep_def gsubst_cl_def)}
  moreover
  {fix s t assume ass: "(s, t) ∈ ?Ls" then obtain u v where
      "(u, v) ∈ par_rstep ℛ" "u = term_of_gterm s" "v = term_of_gterm t"
        by (simp add: gpar_rstep_def inv_image_def)
    then have "(s, t) ∈ ?Rs"
    proof (induct arbitrary: s t)
      case (root_step u v σ)
      then have "(s, t) ∈ gsubst_cl ℛ" unfolding gsubst_cl_def
        by auto (metis ground_substI ground_term_of_gterm term_of_gterm_inv)
      then show ?case by auto
    next
      case (par_step_fun ts ss f)
      then show ?case by (cases s; cases t) auto
    next
      case (par_step_var x)
      then show ?case by (cases s) auto
  qed}
  ultimately show ?thesis by auto
qed

lemma gmctxtcl_funas_idem:
  "gmctxtcl_funas ℱ (gmctxtcl_funas ℱ ℛ) ⊆ gmctxtcl_funas ℱ ℛ"
  by (intro gmctxtex_pred_cmp_subseteq)
    (auto elim!: less_eq_to_sup_mctxt_args, blast+)

lemma gpar_rstepD_gpar_rstepD'_conv:
  "gpar_rstepD ℱ ℛ = gpar_rstepD' ℱ ℛ" (is "?Ls = ?Rs")
proof -
  {fix s t assume "(s, t) ∈ ?Rs" then have "(s, t) ∈ ?Ls"
    proof induct
      case (groot_step s t) then show ?case unfolding gpar_rstepD_def
        using gmctxtex_onpI[of _ GMHole  "[s]" "[t]"]
        by auto
    next
      case (gpar_step_fun ts ss f)
      show ?case using gpar_step_fun(2-) unfolding gpar_rstepD_def
        using subsetD[OF gmctxtcl_funas_idem, of "(GFun f ss, GFun f ts)" ℱ ℛ]
        using gmctxtex_onpI[of _ "GMFun f (replicate (length ss) GMHole)" ss ts "gmctxtcl_funas ℱ ℛ"]
        by (auto simp del: fill_gholes.simps)
    qed}
  moreover
  {fix s t assume "(s, t) ∈ ?Ls" then obtain C ss ts where
    t: "s = fill_gholes C ss" "t = fill_gholes C ts" and
    inv: "num_gholes C = length ss" "num_gholes C = length ts" and
    pred: "funas_gmctxt C ⊆ ℱ" and rel: "∀ i < length ts. (ss ! i, ts ! i) ∈ ℛ"
      unfolding gpar_rstepD_def by auto
    have "(s, t) ∈ ?Rs" using inv pred rel unfolding t
    proof (induct rule: fill_gholes_induct2)
      case (GMHole x) then show ?case
        by (cases ts) auto
    next
      case (GMFun f Cs xs ys)
      from GMFun(1, 2, 5) have "i < length Cs ⟹ ∀ j < length (partition_gholes ys Cs ! i).
        (partition_gholes xs Cs ! i ! j, partition_gholes ys Cs ! i ! j) ∈ ℛ" for i
        by (auto simp: length_partition_by_nth partition_by_nth_nth(1, 2))
      from GMFun this show ?case unfolding partition_holes_fill_gholes_conv'
        by (intro gpar_step_fun) (auto, meson UN_I nth_mem subset_iff)
    qed}
  ultimately show ?thesis by auto
qed

subsection ‹Signature preserving lemmas›

lemma 𝒯G_trans_closure_id [simp]:
  "(𝒯G ℱ × 𝒯G ℱ)+ = 𝒯G ℱ × 𝒯G ℱ"
  by (auto simp: trancl_full_on)

lemma signature_pres_funas_cl [simp]:
  "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ ⟹ gctxtcl_funas ℱ ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ ⟹ gmctxtcl_funas ℱ ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  apply (intro gctxtex_onp_in_signature) apply blast+
  apply (intro gmctxtex_onp_in_signature) apply blast+
  done

lemma relf_on_gmctxtcl_funas:
  assumes "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "refl_on (𝒯G ℱ) (gmctxtcl_funas ℱ ℛ)"
proof -
  have "t ∈ 𝒯G ℱ ⟹ (t, t) ∈ gmctxtcl_funas ℱ ℛ" for t
    using gmctxtex_onpI[of _ "gmctxt_of_gterm t"]
    by (auto simp: 𝒯G_funas_gterm_conv)
  then show ?thesis using assms
    by (auto simp: refl_on_def)
qed

lemma gtrancl_rel_sound:
  "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ ⟹ gtrancl_rel ℱ ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  unfolding gtrancl_rel_def
  by (intro Restr_tracl_comp_simps(3)) (auto simp: gmctxt_cl_gmctxtex_onp_conv)


subsection ‹@{const gcomp_rel} and @{const gtrancl_rel} lemmas›

lemma gcomp_rel:
  "lift_root_step ℱ PAny EParallel (gcomp_rel ℱ ℛ 𝒮) = lift_root_step ℱ PAny EParallel ℛ O lift_root_step ℱ PAny EParallel 𝒮" (is "?Ls = ?Rs")
proof
  { fix s u assume "(s, u) ∈ gpar_rstepD' ℱ (ℛ O gpar_rstepD' ℱ 𝒮 ∪ gpar_rstepD' ℱ ℛ O 𝒮)"
     then have "∃t. (s, t) ∈ gpar_rstepD' ℱ ℛ ∧ (t, u) ∈ gpar_rstepD' ℱ 𝒮"
    proof (induct)
      case (gpar_step_fun ts ss f)
      from Ex_list_of_length_P[of _ "λ u i. (ss ! i, u) ∈ gpar_rstepD' ℱ ℛ ∧ (u, ts ! i) ∈ gpar_rstepD' ℱ 𝒮"]
      obtain us where l: "length us = length ts" and
        inv: "∀ i < length ts. (ss ! i, us ! i) ∈ gpar_rstepD' ℱ ℛ ∧ (us ! i, ts ! i) ∈ gpar_rstepD' ℱ 𝒮"
        using gpar_step_fun(2, 3) by blast
      then show ?case using gpar_step_fun(3, 4)
        by (auto intro!: exI[of _ "GFun f us"])
    qed auto}
  then show "?Ls ⊆ ?Rs" unfolding gcomp_rel_def
    by (auto simp: gmctxt_cl_gmctxtex_onp_conv simp flip: gpar_rstepD_gpar_rstepD'_conv[unfolded gpar_rstepD_def])
next
  {fix s t u assume "(s, t) ∈ gpar_rstepD' ℱ ℛ" "(t, u) ∈ gpar_rstepD' ℱ 𝒮"
    then have "(s, u) ∈ gpar_rstepD' ℱ (ℛ O gpar_rstepD' ℱ 𝒮 ∪ gpar_rstepD' ℱ ℛ O 𝒮)"
    proof (induct arbitrary: u rule: gpar_rstepD'.induct)
      case (gpar_step_fun ts ss f) note IS = this
      show ?case
      proof (cases "(GFun f ts, u) ∈ 𝒮")
        case True
        then have "(GFun f ss, u) ∈ gpar_rstepD' ℱ ℛ O 𝒮" using IS(1, 3, 4)
          by auto
        then show ?thesis by auto
      next
        case False
        then obtain us where u[simp]: "u = GFun f us" and l: "length ts = length us"
          using IS(5) by (cases u) (auto elim!: gpar_rstepD'.cases)
        have "i < length us ⟹
         (ss ! i, us ! i) ∈ gpar_rstepD' ℱ (ℛ O gpar_rstepD' ℱ 𝒮 ∪ gpar_rstepD' ℱ ℛ O 𝒮)" for i
          using IS(2, 5) False
          by (auto elim!: gpar_rstepD'.cases)
        then show ?thesis using l IS(3, 4) unfolding u
          by auto
      qed
    qed auto}
  then show "?Rs ⊆ ?Ls"
    by (auto simp: gmctxt_cl_gmctxtex_onp_conv gcomp_rel_def gpar_rstepD_gpar_rstepD'_conv[unfolded gpar_rstepD_def])
qed

lemma gmctxtcl_funas_in_rtrancl_gctxtcl_funas:
  assumes "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "gmctxtcl_funas ℱ ℛ ⊆ (gctxtcl_funas ℱ ℛ)*" using assms
  by (intro gmctxtex_onp_gctxtex_onp_rtrancl) (auto simp: gmctxt_p_inv_def)

lemma R_in_gtrancl_rel:
  assumes "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "ℛ ⊆ gtrancl_rel ℱ ℛ"
proof
  fix s t assume ass: "(s, t) ∈ ℛ"
  then have "(s, s) ∈ gmctxtcl_funas ℱ ℛ" "(t, t) ∈ gmctxtcl_funas ℱ ℛ" using assms
    using all_ctxt_closed_imp_reflx_on_sig[OF gmctxtcl_funas_sigcl, of ℱ ℛ]
    by auto
  then show "(s, t) ∈ gtrancl_rel ℱ ℛ" using ass
    by (auto simp: gmctxt_cl_gmctxtex_onp_conv relcomp_unfold gtrancl_rel_def)
qed

lemma trans_gtrancl_rel [simp]:
  "trans (gtrancl_rel ℱ ℛ)"
proof -
  have "(s, t) ∈ ℛ ⟹ (s, t) ∈ gmctxtcl_funas ℱ ℛ" for s t
    by (metis bot.extremum funas_gmctxt.simps(2) gmctxtex_closure subsetD)
  then show ?thesis unfolding trans_def gtrancl_rel_def
    by (auto simp: gmctxt_cl_gmctxtex_onp_conv, meson relcomp3_I trancl_into_trancl2 trancl_trans)
qed

lemma gtrancl_rel_cl:
  assumes "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "gmctxtcl_funas ℱ (gtrancl_rel ℱ ℛ) ⊆ (gmctxtcl_funas ℱ ℛ)+"
proof -
 have *:"(s, t) ∈ ℛ ⟹ (s, t) ∈ gmctxtcl_funas ℱ ℛ" for s t
    by (metis bot.extremum funas_gmctxt.simps(2) gmctxtex_closure subsetD)
  have "gmctxtcl_funas ℱ ((gmctxtcl_funas ℱ ℛ)+) ⊆ (gmctxtcl_funas ℱ ℛ)+"
    unfolding gtrancl_rel_def using relf_on_gmctxtcl_funas[OF assms]
    by (intro gmctxtex_onp_substep_trancl, intro gmctxtex_pred_cmp_subseteq2)
       (auto simp: less_sup_gmctxt_args_funas_gmctxt refl_on_def)
  moreover have "gtrancl_rel ℱ ℛ ⊆ (gmctxtcl_funas ℱ ℛ)+"
    unfolding gtrancl_rel_def using *
    by (auto simp: gmctxt_cl_gmctxtex_onp_conv, meson trancl.trancl_into_trancl trancl_trans)
  ultimately show ?thesis using gmctxtex_onp_rel_mono by blast
qed

lemma gtrancl_rel_aux:
  "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ ⟹ gmctxtcl_funas ℱ (gtrancl_rel ℱ ℛ) O gtrancl_rel ℱ ℛ ⊆ gtrancl_rel ℱ ℛ"
  "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ ⟹ gtrancl_rel ℱ ℛ O gmctxtcl_funas ℱ (gtrancl_rel ℱ ℛ) ⊆ gtrancl_rel ℱ ℛ"
  using subsetD[OF gtrancl_rel_cl[of ℛ ℱ]] unfolding gtrancl_rel_def
  by (auto simp: gmctxt_cl_gmctxtex_onp_conv) (meson relcomp3_I trancl_trans)+


declare subsetI [rule del]
lemma gtrancl_rel:
  assumes "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ" "compatible_p Q P"
    and "⋀ C. P C ⟹ funas_gmctxt C ⊆ ℱ"
    and "⋀ C D. P C ⟹ P D ⟹ (C, D) ∈ comp_gmctxt ⟹ P (C ⊓ D)"
  shows "(gctxtex_onp Q ℛ)+ ⊆ gmctxtex_onp P (gtrancl_rel ℱ ℛ)"
proof -
  have fst: "gctxtex_onp Q ℛ ⊆ gctxtex_onp Q (gtrancl_rel ℱ ℛ)"
    using R_in_gtrancl_rel[OF assms(1)]
    by (simp add: gctxtex_onp_rel_mono)
  have snd: "gctxtex_onp Q (gtrancl_rel ℱ ℛ) ⊆ gmctxtex_onp P (gtrancl_rel ℱ ℛ)"
    using assms(2)
    by auto
  have "(gmctxtex_onp P (gtrancl_rel ℱ ℛ))+ = gmctxtex_onp P (gtrancl_rel ℱ ℛ)"
    by (intro gmctxtex_onp_substep_tranclE[of _ "λ C. funas_gmctxt C ⊆ ℱ"])
      (auto simp: gtrancl_rel_aux[OF assms(1)] assms(3, 4) intro: funas_gmctxt_poss_gmctxt_subgm_at_funas)
  then show ?thesis using subset_trans[OF fst snd]
    using trancl_mono_set by fastforce
qed

lemma gtrancl_rel_subseteq_trancl_gctxtcl_funas:
  assumes "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "gtrancl_rel ℱ ℛ ⊆ (gctxtcl_funas ℱ ℛ)+"
proof -
  have [dest!]: "(s, t) ∈ ℛ ⟹ (s, t) ∈ (gctxtcl_funas ℱ ℛ)+" for s t
    using grstepD grstepD_def by blast
  have [dest!]: "(s, t) ∈ (gmctxtcl_funas ℱ ℛ)+ ⟹ (s, t) ∈ (gctxtcl_funas ℱ ℛ)+ ∪ Restr Id (𝒯G ℱ)"
    for s t
    using gmctxtcl_funas_in_rtrancl_gctxtcl_funas[OF assms]
    using signature_pres_funas_cl[OF assms]
    apply (auto simp: gtrancl_rel_def rtrancl_eq_or_trancl intro!: subsetI)
    apply (metis rtranclD rtrancl_trancl_absorb trancl_mono)
    apply (metis mem_Sigma_iff trancl_full_on trancl_mono)+
    done
  then show ?thesis using gtrancl_rel_sound[OF assms]
    by (auto simp: gtrancl_rel_def rtrancl_eq_or_trancl gmctxt_cl_gmctxtex_onp_conv intro!: subsetI)
qed

lemma gmctxtex_onp_gtrancl_rel:
  assumes "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ" and "⋀ C D. Q C ⟹ funas_gctxt D ⊆ ℱ ⟹ Q (C ∘Gc D)"
    and "⋀C. P C ⟹ 0 < num_gholes C ∧ funas_gmctxt C ⊆ ℱ"
    and "⋀C. P C ⟹ gmctxt_p_inv C ℱ Q"
  shows "gmctxtex_onp P (gtrancl_rel ℱ ℛ) ⊆ (gctxtex_onp Q ℛ)+"
proof -
  {fix s t assume ass: "(s, t) ∈ gctxtex_onp Q ((gctxtcl_funas ℱ ℛ)+)"
    from gctxtex_onpE[OF ass] obtain C u v where
      *: "s = C⟨u⟩G" "t = C⟨v⟩G" and
      inv: "Q C" "(u, v) ∈ (gctxtcl_funas ℱ ℛ)+" by blast
    from inv(2) have "(s, t) ∈ (gctxtex_onp Q ℛ)+" unfolding *
    proof induct
      case (base y)
      then show ?case using assms(2)[OF inv(1)]
        by (auto elim!: gctxtex_onpE) (metis ctxt_ctxt_compose gctxtex_onpI trancl.r_into_trancl)
    next
      case (step y z)
      from step(2) have "(C⟨y⟩G, C⟨z⟩G) ∈  gctxtex_onp Q ℛ" using assms(2)[OF inv(1)]
        by (auto elim!: gctxtex_onpE) (metis ctxt_ctxt_compose gctxtex_onpI) 
      then show ?case using step(3)
        by auto
    qed}
  then have con: "gctxtex_onp Q ((gctxtcl_funas ℱ ℛ)+) ⊆ (gctxtex_onp Q ℛ)+"
    using subrelI by blast
  have snd: "gmctxtex_onp P ((gctxtcl_funas ℱ ℛ)+) ⊆ (gctxtex_onp Q ((gctxtcl_funas ℱ ℛ)+))+"
    using assms(1)
    by (intro gmctxtex_onp_gctxtex_onp_trancl[OF assms(3) _ assms(4)]) auto
  have fst: "gmctxtex_onp P (gtrancl_rel ℱ ℛ) ⊆ gmctxtex_onp P ((gctxtcl_funas ℱ ℛ)+)"
    using gtrancl_rel_subseteq_trancl_gctxtcl_funas[OF assms(1)]
    by (simp add: gmctxtex_onp_rel_mono)
  show ?thesis using subset_trans[OF fst snd] con
    by (auto intro!: subsetI)
       (metis (no_types, lifting) in_mono rtrancl_trancl_trancl tranclD2 trancl_mono trancl_rtrancl_absorb)
qed

lemma gmctxtcl_funas_strict_gtrancl_rel:
  assumes "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "gmctxtcl_funas_strict ℱ (gtrancl_rel ℱ ℛ) = (gctxtcl_funas ℱ ℛ)+" (is "?Ls = ?Rs")
proof
  show "?Ls ⊆ ?Rs"
    by (intro gmctxtex_onp_gtrancl_rel[OF assms]) (auto simp: gmctxt_p_inv_def)
next
  show "?Rs ⊆ ?Ls"
    by (intro gtrancl_rel[OF assms])
       (auto simp: compatible_p_def num_gholes_at_least1
          intro: subset_trans[OF inf_funas_gmctxt_subset2])
qed

lemma gmctxtex_funas_nroot_strict_gtrancl_rel:
  assumes "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "gmctxtex_funas_nroot_strict ℱ (gtrancl_rel ℱ ℛ) = (gctxtex_funas_nroot ℱ ℛ)+"
 (is "?Ls = ?Rs")
proof
  show "?Ls ⊆ ?Rs"
    by (intro gmctxtex_onp_gtrancl_rel[OF assms])
       (auto simp: gmctxt_p_inv_def gmctxt_closing_def
        dest!: less_eq_gmctxt_Hole gctxt_of_gmctxt_hole_dest gctxt_compose_HoleE(1))
next
  show "?Rs ⊆ ?Ls"
    by (intro gtrancl_rel[OF assms])
       (auto simp: compatible_p_def num_gholes_at_least1
          elim!: comp_gmctxt.cases
          dest: gmctxt_of_gctxt_GMHole_Hole
          intro: subset_trans[OF inf_funas_gmctxt_subset2])
qed

lemma lift_root_step_sig':
  assumes "ℛ ⊆ 𝒯G 𝒢 × 𝒯G ℋ" "ℱ ⊆ 𝒢" "ℱ ⊆ ℋ"
  shows "lift_root_step ℱ W X ℛ ⊆ 𝒯G 𝒢 × 𝒯G ℋ"
  using assms 𝒯G_mono
  by (cases W; cases X) (auto simp add: Sigma_mono 𝒯G_mono inf.coboundedI2)

lemmas lift_root_step_sig = lift_root_step_sig'[OF _ subset_refl subset_refl]

lemma lift_root_step_incr:
  "ℛ ⊆ 𝒮 ⟹ lift_root_step ℱ W X ℛ ⊆ lift_root_step ℱ W X 𝒮"
  by (cases W; cases X) (auto simp add: le_supI1 gctxtex_onp_rel_mono gmctxtex_onp_rel_mono)

lemma Restr_id_mono:
  "ℱ ⊆ 𝒢 ⟹ Restr Id (𝒯G ℱ) ⊆ Restr Id (𝒯G 𝒢)"
  by (meson Sigma_mono 𝒯G_mono inf_mono subset_refl)

lemma lift_root_step_mono:
  "ℱ ⊆ 𝒢 ⟹ lift_root_step ℱ W X ℛ ⊆ lift_root_step 𝒢 W X ℛ"
  by (cases W; cases X) (auto simp: Restr_id_mono intro: gmctxtex_onp_mono gctxtex_onp_mono,
   metis Restr_id_mono sup.coboundedI1 sup_commute)


lemma grstep_lift_root_step:
  "lift_root_step ℱ PAny ESingle (Restr (grrstep ℛ) (𝒯G ℱ)) = Restr (grstep ℛ) (𝒯G ℱ)"
  unfolding grstepD_grstep_conv grstepD_def grrstep_subst_cl_conv
  by auto

lemma prod_swap_id_on_refl [simp]:
  "Restr Id (𝒯G ℱ) ⊆ prod.swap ` (ℛ ∪ Restr Id (𝒯G ℱ))"
  by (auto intro: subsetI)

lemma swap_lift_root_step:
  "lift_root_step ℱ W X (prod.swap ` ℛ) = prod.swap ` lift_root_step ℱ W X ℛ"
  by (cases W; cases X) (auto simp add: image_mono swap_gmctxtex_onp swap_gctxtex_onp intro: subsetI)

lemma converse_lift_root_step:
  "(lift_root_step ℱ W X R)¯ = lift_root_step ℱ W X (R¯)"
  by (cases W; cases X) (auto simp add: converse_gctxtex_onp converse_gmctxtex_onp intro: subsetI)

lemma lift_root_step_sig_transfer:
  assumes "p ∈ lift_root_step ℱ W X R" "snd ` R ⊆ 𝒯G ℱ" "funas_gterm (fst p) ⊆ 𝒢"
  shows "p ∈ lift_root_step 𝒢 W X R" using assms
proof -
  from assms have "p ∈ lift_root_step (ℱ ∩ 𝒢) W X R"
    by (cases p; cases W; cases X)
       (auto simp: gctxtex_onp_sign_trans_fst[of _ _ _ R 𝒢] gctxtex_onp_sign_trans_snd[of _ _ _ R 𝒢]
          gmctxtex_onp_sign_trans_fst gmctxtex_onp_sign_trans_snd simp flip: 𝒯G_equivalent_def 𝒯G_funas_gterm_conv
          intro: basic_trans_rules(30)[OF gctxtex_onp_sign_trans_fst[of _ _ _ R 𝒢],
              where ?B = "gctxtex_onp P R" for P]
            basic_trans_rules(30)[OF gmctxtex_onp_sign_trans_fst[of _ _ _ R 𝒢],
              where ?B = "gmctxtex_onp P R" for P])
   then show ?thesis
    by (meson inf.cobounded2 lift_root_step_mono subsetD)
qed


lemma lift_root_step_sig_transfer2:
  assumes "p ∈ lift_root_step ℱ W X R" "snd ` R ⊆ 𝒯G 𝒢" "funas_gterm (fst p) ⊆ 𝒢"
  shows "p ∈ lift_root_step 𝒢 W X R"
proof -
  from assms have "p ∈ lift_root_step (ℱ ∩ 𝒢) W X R"
    by (cases p; cases W; cases X)
       (auto simp: gctxtex_onp_sign_trans_fst[of _ _ _ R 𝒢] gctxtex_onp_sign_trans_snd[of _ _ _ R 𝒢]
          gmctxtex_onp_sign_trans_fst gmctxtex_onp_sign_trans_snd simp flip: 𝒯G_equivalent_def 𝒯G_funas_gterm_conv
          intro: basic_trans_rules(30)[OF gctxtex_onp_sign_trans_fst[of _ _ _ R 𝒢],
              where ?B = "gctxtex_onp P R" for P]
            basic_trans_rules(30)[OF gmctxtex_onp_sign_trans_fst[of _ _ _ R 𝒢],
              where ?B = "gmctxtex_onp P R" for P])
   then show ?thesis
    by (meson inf.cobounded2 lift_root_step_mono subsetD)
qed

lemma lift_root_steps_sig_transfer:
  assumes "(s, t) ∈ (lift_root_step ℱ W X R)+" "snd ` R ⊆ 𝒯G 𝒢" "funas_gterm s ⊆ 𝒢"
  shows "(s, t) ∈ (lift_root_step 𝒢 W X R)+"
  using assms(1,3)
proof (induct rule: converse_trancl_induct)
  case (base s)
  show ?case using lift_root_step_sig_transfer2[OF base(1) assms(2)] base(2) by (simp add: r_into_trancl)
next
  case (step s s')
  show ?case using lift_root_step_sig_transfer2[OF step(1) assms(2)] step(3,4)
      lift_root_step_sig'[of R UNIV 𝒢 𝒢 W X, THEN subsetD, of "(s, s')"] assms(2)
    by (auto simp: 𝒯G_funas_gterm_conv 𝒯G_equivalent_def)
       (smt SigmaI UNIV_I image_subset_iff snd_conv subrelI trancl_into_trancl2)
qed

lemma lift_root_stepseq_sig_transfer:
  assumes "(s, t) ∈ (lift_root_step ℱ W X R)*" "snd ` R ⊆ 𝒯G 𝒢" "funas_gterm s ⊆ 𝒢"
  shows "(s, t) ∈ (lift_root_step 𝒢 W X R)*"
  using assms by (auto simp flip: reflcl_trancl simp: lift_root_steps_sig_transfer)

lemmas lift_root_step_sig_transfer' = lift_root_step_sig_transfer[of "prod.swap p" ℱ W X "prod.swap ` R" 𝒢 for p ℱ W X 𝒢 R,
    unfolded swap_lift_root_step, OF imageI, THEN imageI [of _ _ prod.swap],
    unfolded image_comp comp_def fst_swap snd_swap swap_swap image_ident]

lemmas lift_root_steps_sig_transfer' = lift_root_steps_sig_transfer[of t s ℱ W X "prod.swap ` R" 𝒢 for t s ℱ W X 𝒢 R,
    THEN imageI [of _ _ prod.swap], unfolded swap_lift_root_step swap_trancl pair_in_swap_image
    image_comp comp_def snd_swap swap_swap swap_simp image_ident]

lemmas lift_root_stepseq_sig_transfer' = lift_root_stepseq_sig_transfer[of t s ℱ W X "prod.swap ` R" 𝒢 for t s ℱ W X 𝒢 R,
    THEN imageI [of _ _ prod.swap], unfolded swap_lift_root_step swap_rtrancl pair_in_swap_image
    image_comp comp_def snd_swap swap_swap swap_simp image_ident]

lemma lift_root_step_PRoot_ESingle [simp]:
  "lift_root_step ℱ PRoot ESingle ℛ = ℛ"
  by auto

lemma lift_root_step_PRoot_EStrictParallel [simp]:
  "lift_root_step ℱ PRoot EStrictParallel ℛ = ℛ"
  by auto

lemma lift_root_step_Parallel_conv:
  shows "lift_root_step ℱ W EParallel ℛ = lift_root_step ℱ W EStrictParallel ℛ ∪ Restr Id (𝒯G ℱ)"
  by (cases W) (auto simp: gmctxtcl_funas_dist gmctxtex_funas_nroot_dist)

lemma relax_pos_lift_root_step:
  "lift_root_step ℱ W X R ⊆ lift_root_step ℱ PAny X R"
  by (cases W; cases X) (auto simp: gctxtex_closure gmctxtex_closure)

lemma relax_pos_lift_root_steps:
  "(lift_root_step ℱ W X R)+ ⊆ (lift_root_step ℱ PAny X R)+"
  by (simp add: relax_pos_lift_root_step trancl_mono_set)

lemma relax_ext_lift_root_step:
  "lift_root_step ℱ W X R ⊆ lift_root_step ℱ W EParallel R"
  by (cases W; cases X) (auto simp: compatible_p_gctxtex_gmctxtex_subseteq)

lemma lift_root_step_StrictParallel_seq:
  assumes "R ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "lift_root_step ℱ PAny EStrictParallel R ⊆ (lift_root_step ℱ PAny ESingle R)+"
  using assms
  by (auto simp: gmctxt_p_inv_def intro!: gmctxtex_onp_gctxtex_onp_trancl)

lemma lift_root_step_Parallel_seq:
  assumes "R ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "lift_root_step ℱ PAny EParallel R ⊆ (lift_root_step ℱ PAny ESingle R)+ ∪ Restr Id (𝒯G ℱ)"
  unfolding lift_root_step_Parallel_conv using lift_root_step_StrictParallel_seq[OF assms]
  using Un_mono by blast

lemma lift_root_step_Single_to_Parallel:
  shows "lift_root_step ℱ PAny ESingle R ⊆ lift_root_step ℱ PAny EParallel R"
  by (simp add: compatible_p_gctxtex_gmctxtex_subseteq)

lemma trancl_partial_reflcl:
  "(X ∪ Restr Id Y)+ = X+ ∪ Restr Id Y"
proof (intro equalityI subrelI, goal_cases LR RL)
  case (LR a b) then show ?case by (induct) (auto dest: trancl_into_trancl)
qed (auto intro: trancl_mono)

lemma lift_root_step_Parallels_single:
  assumes "R ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "(lift_root_step ℱ PAny EParallel R)+ = (lift_root_step ℱ PAny ESingle R)+ ∪ Restr Id (𝒯G ℱ)"
  using trancl_mono_set[OF lift_root_step_Parallel_seq[OF assms]]
  using trancl_mono_set[OF lift_root_step_Single_to_Parallel, of ℱ R]
  by (auto simp: lift_root_step_Parallel_conv trancl_partial_reflcl)


lemma lift_root_Any_Single_eq:
  shows "lift_root_step ℱ PAny ESingle R = R ∪ lift_root_step ℱ PNonRoot ESingle R"
  by (auto simp: gctxtcl_funas_dist intro!: gctxtex_closure)

lemma lift_root_Any_EStrict_eq [simp]:
  shows "lift_root_step ℱ PAny EStrictParallel R = R ∪ lift_root_step ℱ PNonRoot EStrictParallel R"
  by (auto simp: gmctxtcl_funas_strict_dist)

lemma gar_rstep_lift_root_step:
  "lift_root_step ℱ PAny EParallel (Restr (grrstep ℛ) (𝒯G ℱ)) = Restr (gpar_rstep ℛ) (𝒯G ℱ)"
  unfolding grrstep_subst_cl_conv gpar_rstep_gpar_rstepD_conv
  unfolding gpar_rstepD_gpar_rstepD'_conv[symmetric]
  by (auto simp: gpar_rstepD_def)

lemma grrstep_lift_root_gnrrstep:
  "lift_root_step ℱ PNonRoot ESingle (Restr (grrstep ℛ) (𝒯G ℱ)) = Restr (gnrrstep ℛ) (𝒯G ℱ)"
  unfolding gnrrstepD_gnrrstep_conv grrstep_subst_cl_conv
  by (simp add: gnrrstepD_def)

(* Restoring Isabelle standard attributes to lemmas *)
declare subsetI [intro!] 
declare lift_root_step.simps[simp del]

lemma gpar_rstepD_grstepD_rtrancl_subseteq:
  assumes "ℛ ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "gpar_rstepD ℱ ℛ ⊆ (grstepD ℱ ℛ)*"
  using assms unfolding gpar_rstepD_def grstepD_def
  by (intro gmctxtex_onp_gctxtex_onp_rtrancl) (auto simp: 𝒯G_equivalent_def gmctxt_p_inv_def)
end
y>

Theory Context_RR2

theory Context_RR2
  imports Context_Extensions
    Ground_MCtxt
    Regular_Tree_Relations.RRn_Automata
begin

subsection ‹Auxiliary lemmas›
(* TODO Move *)
lemma gpair_gctxt:
  assumes "gpair s t = u"
  shows "(map_gctxt (λ f .(Some f, Some f)) C)⟨u⟩G = gpair C⟨s⟩G C⟨t⟩G" using assms
  by (induct C arbitrary: s t u) (auto simp add: gpair_context1 comp_def map_funs_term_some_gpair intro!: nth_equalityI)

lemma gpair_gctxt':
  assumes "gpair C⟨v⟩G C⟨w⟩G = u"
  shows "u = (map_gctxt (λ f .(Some f, Some f)) C)⟨gpair v w⟩G"
  using assms by (simp add: gpair_gctxt)

lemma gpair_gmctxt:
  assumes "∀ i < length us. gpair (ss ! i) (ts ! i) = us ! i"
    and "num_gholes C = length ss" "length ss = length ts" "length ts = length us"
  shows "fill_gholes (map_gmctxt (λf . (Some f, Some f)) C) us = gpair (fill_gholes C ss) (fill_gholes C ts)"
  using assms
proof (induct C arbitrary: ss ts us)
  case GMHole
  then show ?case by (cases ss; cases ts; cases us) auto
next
  case (GMFun f Cs)
  show ?case using GMFun(2-)
    using GMFun(1)[OF nth_mem, of i "partition_gholes us Cs ! i" "partition_gholes ss Cs ! i" "partition_gholes ts Cs ! i" for i]
    using length_partition_gholes_nth[of Cs] partition_by_nth_nth[of "map num_gholes Cs" us]
    using partition_by_nth_nth[of "map num_gholes Cs" ss] partition_by_nth_nth[of "map num_gholes Cs" ts]
    by (auto simp: partition_holes_fill_gholes_conv' gpair_context1 simp del: fill_gholes.simps intro!: nth_equalityI)
      (simp add: length_partition_gholes_nth)
qed
(*Finished Move section*)


lemma gctxtex_onp_gpair_set_conv:
  "{gpair t u |t u. (t, u) ∈ gctxtex_onp P ℛ} =
    {(map_gctxt (λ f .(Some f, Some f)) C)⟨s⟩G | C s. P C ∧ s ∈ {gpair t u |t u. (t, u) ∈ ℛ}}" (is "?Ls = ?Rs")
proof
  show "?Ls ⊆ ?Rs" using gpair_gctxt'
    by (auto elim!: gctxtex_onpE) blast
next
  show "?Rs ⊆ ?Ls"
    by (auto simp add: gctxtex_onpI gpair_gctxt)
qed

lemma gmctxtex_onp_gpair_set_conv:
  "{gpair t u |t u. (t, u) ∈ gmctxtex_onp P ℛ} =
    {fill_gholes (map_gmctxt (λ f .(Some f, Some f)) C) ss | C ss. num_gholes C = length ss ∧ P C ∧
     (∀ i < length ss. ss ! i ∈ {gpair t u |t u. (t, u) ∈ ℛ})}" (is "?Ls = ?Rs")
proof
  {fix u assume "u ∈ ?Ls" then obtain s t
      where *: "u = gpair s t" "(s, t) ∈ gmctxtex_onp P ℛ"
      by auto
    from gmctxtex_onpE[OF *(2)] obtain C us vs where
      **: "s = fill_gholes C us" "t = fill_gholes C vs" and
      inv: "num_gholes C = length us" "length us = length vs" "P C"
       "∀ i < length vs. (us ! i, vs ! i) ∈ ℛ"
      by blast
    define ws where "ws ≡ map2 gpair us vs"
    from inv(1, 2) have "∀ i < length ws. gpair (us ! i) (vs ! i) =  ws ! i"
      by(auto simp: ws_def)
    from gpair_gmctxt[OF this inv(1, 2)] inv
    have "u ∈ ?Rs" unfolding * **
      by (auto simp: ws_def intro!: exI[of _ ws] exI[of _ C])}
  then show "?Ls ⊆ ?Rs" by blast
next
  {fix u assume "u ∈ ?Rs" then obtain C ss where
    *: "u = fill_gholes (map_gmctxt (λf. (Some f, Some f)) C) ss" and
    inv: "P C" "num_gholes C = length ss" "∀ i < length ss. ∃ t u. ss ! i = gpair t u ∧ (t, u) ∈ ℛ"
      by auto
    define us where "us ≡ map gfst ss" define vs where "vs ≡ map gsnd ss"
    then have len: "length ss = length us" "length us = length vs" and
      rec: "∀ i < length ss. gpair (us ! i) (vs ! i) = ss ! i"
        "∀ i < length vs. (us ! i, vs ! i) ∈ ℛ"
      by (auto simp: us_def vs_def) (metis gfst_gpair gsnd_gpair inv(3))+
    from len have l: "length vs = length ss" by auto
    have "u ∈ ?Ls" unfolding * using inv(2) len
      using gmctxtex_onpI[of P C us vs ℛ, OF inv(1) _ len(2) rec(2)]
      using gpair_gmctxt[OF rec(1) _ len(2) l, of C]
      by simp}
  then show "?Rs ⊆ ?Ls" by blast
qed


(* Results about lifting signature to RR2
  TODO rework, as this is not the RR2 signature more like
  the context signature, so closing a RR2 term under this signature
  leads a RR2 term
*)

abbreviation "lift_sig_RR2 ≡ λ (f, n). ((Some f, Some f), n)"
abbreviation "lift_fun ≡ (λ f. (Some f, Some f))"
abbreviation "unlift_fst ≡ (λ f. the (fst f))"
abbreviation "unlift_snd ≡ (λ f. the (snd f))"

lemma RR2_gterm_unlift_lift_id [simp]:
  "funas_gterm t ⊆ lift_sig_RR2 ` ℱ ⟹ map_gterm (lift_fun ∘ unlift_fst) t = t"
  by (induct t) (auto simp add: SUP_le_iff map_idI)

lemma RR2_gterm_unlift_funas [simp]:
  "funas_gterm t ⊆ lift_sig_RR2 ` ℱ ⟹ funas_gterm (map_gterm unlift_fst t) ⊆ ℱ"
  by (induct t) (auto simp add: SUP_le_iff map_idI)

lemma gterm_funas_lift_RR2_funas [simp]:
  "funas_gterm t ⊆ ℱ ⟹ funas_gterm (map_gterm lift_fun t) ⊆ lift_sig_RR2 ` ℱ"
  by (induct t) (auto simp add: SUP_le_iff map_idI)

lemma RR2_gctxt_unlift_lift_id [simp, intro]:
  "funas_gctxt C ⊆ lift_sig_RR2 ` ℱ ⟹ (map_gctxt (lift_fun ∘ unlift_fst) C) = C"
  by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)

lemma RR2_gctxt_unlift_funas [simp, intro]:
  "funas_gctxt C ⊆ lift_sig_RR2 ` ℱ ⟹ funas_gctxt (map_gctxt unlift_fst C) ⊆ ℱ"
  by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)

lemma gctxt_funas_lift_RR2_funas [simp, intro]:
  "funas_gctxt C ⊆ ℱ ⟹ funas_gctxt (map_gctxt lift_fun C) ⊆ lift_sig_RR2 ` ℱ"
  by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)

lemma RR2_gmctxt_unlift_lift_id [simp, intro]:
  "funas_gmctxt C ⊆ lift_sig_RR2 ` ℱ ⟹ (map_gmctxt (lift_fun ∘ unlift_fst) C) = C"
  by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)

lemma RR2_gmctxt_unlift_funas [simp, intro]:
  "funas_gmctxt C ⊆ lift_sig_RR2 ` ℱ ⟹ funas_gmctxt (map_gmctxt unlift_fst C) ⊆ ℱ"
  by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)

lemma gmctxt_funas_lift_RR2_funas [simp, intro]:
  "funas_gmctxt C ⊆ ℱ ⟹ funas_gmctxt (map_gmctxt lift_fun C) ⊆ lift_sig_RR2 ` ℱ"
  by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)

lemma RR2_gctxt_cl_to_gctxt:
  assumes "⋀ C. P C ⟹ funas_gctxt C ⊆ lift_sig_RR2 ` ℱ"
    and "⋀ C. P C ⟹ R (map_gctxt unlift_fst C)"
    and "⋀ C. R C ⟹ P (map_gctxt lift_fun C)"
  shows "{C⟨s⟩G |C s. P C ∧ Q s} = {(map_gctxt lift_fun C)⟨s⟩G |C s. R C ∧ Q s}" (is "?Ls = ?Rs")
proof
  {fix u assume "u ∈ ?Ls" then obtain C s where
    *:"u = C⟨s⟩G" and inv: "P C" "Q s" by blast
    then have "funas_gctxt C ⊆ lift_sig_RR2 ` ℱ" using assms by auto
    from RR2_gctxt_unlift_lift_id[OF this] have "u ∈ ?Rs" using inv assms unfolding * 
      by (auto intro!: exI[of _ "map_gctxt unlift_fst C"] exI[of _ s])}
  then show "?Ls ⊆ ?Rs" by blast
next
  {fix u assume "u ∈ ?Rs" then obtain C s where
    *:"u = (map_gctxt lift_fun C)⟨s⟩G" and inv: "R C" "Q s"
      by blast
    have "u ∈ ?Ls" unfolding * using inv assms
      by (auto intro!: exI[of _ "map_gctxt lift_fun C"])}
  then show "?Rs ⊆ ?Ls" by blast
qed

lemma RR2_gmctxt_cl_to_gmctxt:
  assumes "⋀ C. P C ⟹ funas_gmctxt C ⊆ lift_sig_RR2 ` ℱ"
    and "⋀ C. P C ⟹ R (map_gmctxt (λ f. the (fst f)) C)"
    and "⋀ C. R C ⟹ P (map_gmctxt (λ f. (Some f, Some f)) C)"
  shows "{fill_gholes C ss |C ss. num_gholes C = length ss ∧ P C ∧ (∀ i < length ss. Q (ss ! i))} =
    {fill_gholes (map_gmctxt (λf. (Some f, Some f)) C) ss |C ss. num_gholes C = length ss ∧
     R C ∧ (∀ i < length ss. Q (ss ! i))}" (is "?Ls = ?Rs")
proof
  {fix u assume "u ∈ ?Ls" then obtain C ss where
    *:"u = fill_gholes C ss" and inv: "num_gholes C = length ss" "P C" "∀ i < length ss. Q (ss ! i)"
      by blast
    then have "funas_gmctxt C ⊆ lift_sig_RR2 ` ℱ" using assms by auto
    from RR2_gmctxt_unlift_lift_id[OF this] have "u ∈ ?Rs" using inv assms unfolding * 
      by (auto intro!: exI[of _ "map_gmctxt unlift_fst C"] exI[of _ ss])}
  then show "?Ls ⊆ ?Rs" by blast
next
  {fix u assume "u ∈ ?Rs" then obtain C ss where
    *:"u = fill_gholes (map_gmctxt lift_fun C) ss" and inv: "num_gholes C = length ss" "R C"
      "∀ i < length ss. Q (ss ! i)"
      by blast
    have "u ∈ ?Ls" unfolding * using inv assms
      by (auto intro!: exI[of _ "map_gmctxt lift_fun C"])}
  then show "?Rs ⊆ ?Ls" by blast
qed

lemma RR2_id_terms_gpair_set [simp]:
 "𝒯G (lift_sig_RR2 ` ℱ) = {gpair t u |t u. (t, u) ∈ Restr Id (𝒯G ℱ)}"
 apply (auto simp: map_funs_term_some_gpair 𝒯G_equivalent_def)
 apply (smt RR2_gterm_unlift_funas RR2_gterm_unlift_lift_id gterm.map_comp)
 using funas_gterm_map_gterm by blast

end
div class="head">

Theory GTT_RRn

theory GTT_RRn
  imports Regular_Tree_Relations.GTT
    TA_Clousure_Const
    Context_RR2
    Lift_Root_Step
begin                 


section ‹Connecting regular tree languages to set/relation specifications›
abbreviation ggtt_lang where
  "ggtt_lang F G ≡ map_both gterm_of_term ` (Restr (gtt_lang_terms G) {t. funas_term t ⊆ fset F})"

lemma ground_mctxt_map_vars_mctxt [simp]:
  "ground_mctxt (map_vars_mctxt f C) = ground_mctxt C"
  by (induct C) auto

lemma root_single_automaton:
  assumes "RR2_spec 𝒜 R"
  shows "RR2_spec 𝒜 (lift_root_step ℱ PRoot ESingle R)"
  using assms unfolding RR2_spec_def
  by (auto simp: lift_root_step.simps)

lemma root_strictparallel_automaton:
  assumes "RR2_spec 𝒜 R"
  shows "RR2_spec 𝒜 (lift_root_step ℱ PRoot EStrictParallel R)"
  using assms unfolding RR2_spec_def
  by (auto simp: lift_root_step.simps)

lemma reflcl_automaton:
  assumes "RR2_spec 𝒜 R"
  shows "RR2_spec (reflcl_reg (lift_sig_RR2 |`| ℱ) 𝒜) (lift_root_step (fset ℱ) PRoot EParallel R)"
   unfolding RR2_spec_def ℒ_reflcl_reg
   unfolding lift_root_step.simps 𝒯G_equivalent_def assms[unfolded RR2_spec_def]
   by (auto simp flip: 𝒯G_equivalent_def)

lemma parallel_closure_automaton:
  assumes "RR2_spec 𝒜 R"
  shows "RR2_spec (parallel_closure_reg (lift_sig_RR2 |`| ℱ) 𝒜) (lift_root_step (fset ℱ) PAny EParallel R)"
  unfolding RR2_spec_def parallelcl_gmctxt_lang lift_root_step.simps
  unfolding gmctxtex_onp_gpair_set_conv assms[unfolded RR2_spec_def]
  by (intro RR2_gmctxt_cl_to_gmctxt) auto

lemma ctxt_closure_automaton:
  assumes "RR2_spec 𝒜 R"
  shows "RR2_spec (ctxt_closure_reg (lift_sig_RR2 |`| ℱ) 𝒜) (lift_root_step (fset ℱ) PAny ESingle R)"
  unfolding RR2_spec_def gctxt_closure_lang lift_root_step.simps
  unfolding gctxtex_onp_gpair_set_conv assms[unfolded RR2_spec_def]
  by (intro RR2_gctxt_cl_to_gctxt) auto

lemma mctxt_closure_automaton:
  assumes "RR2_spec 𝒜 R"
  shows "RR2_spec (mctxt_closure_reg (lift_sig_RR2 |`| ℱ) 𝒜) (lift_root_step (fset ℱ) PAny EStrictParallel R)"
  unfolding RR2_spec_def gmctxt_closure_lang lift_root_step.simps
  unfolding gmctxtex_onp_gpair_set_conv assms[unfolded RR2_spec_def] conj_assoc
  by (intro RR2_gmctxt_cl_to_gmctxt[where ?P = "λ C. 0 < num_gholes C ∧ funas_gmctxt C ⊆ fset (lift_sig_RR2 |`| ℱ)" and
       ?R = "λ C. 0 < num_gholes C ∧ funas_gmctxt C ⊆ fset ℱ", unfolded conj_assoc]) auto

lemma nhole_ctxt_closure_automaton:
  assumes "RR2_spec 𝒜 R"
  shows "RR2_spec (nhole_ctxt_closure_reg (lift_sig_RR2 |`| ℱ) 𝒜) (lift_root_step (fset ℱ) PNonRoot ESingle R)"
  unfolding RR2_spec_def nhole_ctxtcl_lang lift_root_step.simps
  unfolding gctxtex_onp_gpair_set_conv assms[unfolded RR2_spec_def]
  by (intro RR2_gctxt_cl_to_gctxt[where
    ?P = "λ C. C ≠ □G ∧ funas_gctxt C ⊆ fset (lift_sig_RR2 |`| ℱ)", unfolded conj_assoc]) auto

lemma nhole_mctxt_closure_automaton:
  assumes "RR2_spec 𝒜 R"
  shows "RR2_spec (nhole_mctxt_closure_reg (lift_sig_RR2 |`| ℱ) 𝒜) (lift_root_step (fset ℱ) PNonRoot EStrictParallel R)"
  unfolding RR2_spec_def nhole_gmctxt_closure_lang lift_root_step.simps
  unfolding gmctxtex_onp_gpair_set_conv assms[unfolded RR2_spec_def]
  by (intro RR2_gmctxt_cl_to_gmctxt[where
    ?P = "λ C. 0 < num_gholes C ∧ C ≠ GMHole ∧ funas_gmctxt C ⊆ fset (lift_sig_RR2 |`| ℱ)", unfolded conj_assoc])
    auto

lemma nhole_mctxt_reflcl_automaton:
  assumes "RR2_spec 𝒜 R"
  shows "RR2_spec (nhole_mctxt_reflcl_reg (lift_sig_RR2 |`| ℱ) 𝒜) (lift_root_step (fset ℱ) PNonRoot EParallel R)"
  using nhole_mctxt_closure_automaton[OF assms, of ℱ]
  unfolding RR2_spec_def lift_root_step_Parallel_conv nhole_mctxt_reflcl_lang
  by (auto simp flip: 𝒯G_equivalent_def)

definition GTT_to_RR2_root :: "('q, 'f) gtt ⇒ (_, 'f option × 'f option) ta" where
  "GTT_to_RR2_root 𝒢 = pair_automaton (fst 𝒢) (snd 𝒢)"

definition GTT_to_RR2_root_reg where
  "GTT_to_RR2_root_reg 𝒢 = Reg (map_both Some |`| fId_on (gtt_states 𝒢)) (GTT_to_RR2_root 𝒢)"

lemma GTT_to_RR2_root:
  "RR2_spec (GTT_to_RR2_root_reg 𝒢) (agtt_lang 𝒢)"
proof -
  { fix s assume "s ∈ ℒ (GTT_to_RR2_root_reg 𝒢)"
    then obtain q where q: "q |∈| fin (GTT_to_RR2_root_reg 𝒢)" "q |∈| ta_der (GTT_to_RR2_root 𝒢) (term_of_gterm s)"
      by (auto simp: ℒ_def gta_lang_def GTT_to_RR2_root_reg_def gta_der_def)
    then obtain q' where [simp]: "q = (Some q', Some q')" using q(1) by (auto simp: GTT_to_RR2_root_reg_def)
    have "∃t u q. s = gpair t u ∧ q |∈| ta_der (fst 𝒢) (term_of_gterm t) ∧ q |∈| ta_der (snd 𝒢) (term_of_gterm u)"
      using fsubsetD[OF ta_der_mono' q(2), of "pair_automaton (fst 𝒢) (snd 𝒢)"]
      by (auto simp: GTT_to_RR2_root_def dest!: from_ta_der_pair_automaton(4))
  } moreover
  { fix t u q assume q: "q |∈| ta_der (fst 𝒢) (term_of_gterm t)" "q |∈| ta_der (snd 𝒢) (term_of_gterm u)"
    have "lift_fun q |∈| map_both Some |`| fId_on (𝒬 (fst 𝒢) |∪| 𝒬 (snd 𝒢))"
      using q[THEN fsubsetD[OF ground_ta_der_states[OF  ground_term_of_gterm]]]
      by (auto simp: fimage_iff fBex_def)
    then have "gpair t u ∈ ℒ (GTT_to_RR2_root_reg 𝒢)" using q
      using fsubsetD[OF ta_der_mono to_ta_der_pair_automaton(3)[OF q], of "GTT_to_RR2_root 𝒢"]
      by (auto simp: ℒ_def GTT_to_RR2_root_def gta_lang_def image_def gtt_states_def
        gta_der_def GTT_to_RR2_root_reg_def)
  } ultimately show ?thesis by (auto simp: RR2_spec_def agtt_lang_def ℒ_def gta_der_def)
qed

lemma swap_GTT_to_RR2_root:
  "gpair s t ∈ ℒ (GTT_to_RR2_root_reg (prod.swap 𝒢)) ⟷
   gpair t s ∈ ℒ (GTT_to_RR2_root_reg 𝒢)"
  by (auto simp: GTT_to_RR2_root[unfolded RR2_spec_def] agtt_lang_def)

lemma funas_mctxt_map_vars_mctxt [simp]:
  "funas_mctxt (map_vars_mctxt f C) = funas_mctxt C"
  by (induct C) auto

definition GTT_to_RR2_reg  :: "('f × nat) fset ⇒ ('q, 'f) gtt ⇒ (_, 'f option × 'f option) reg" where
  "GTT_to_RR2_reg F G = parallel_closure_reg (lift_sig_RR2 |`| F) (GTT_to_RR2_root_reg G)"

lemma agtt_lang_syms:
  "gtt_syms 𝒢 |⊆| ℱ ⟹ agtt_lang 𝒢 ⊆ {t. funas_gterm t ⊆ fset ℱ} × {t. funas_gterm t ⊆ fset ℱ}"
  by (auto simp: agtt_lang_def gta_der_def funas_term_of_gterm_conv)
     (metis ffunas_gterm.rep_eq fin_mono notin_fset ta_der_gterm_sig)+


lemma gtt_lang_from_agtt_lang:
  "gtt_lang 𝒢 = lift_root_step UNIV PAny EParallel (agtt_lang 𝒢)"
  unfolding lift_root_step.simps agtt_lang_def
  by (auto simp: lift_root_step.simps agtt_lang_def gmctxt_cl_gmctxtex_onp_conv)

lemma GTT_to_RR2:
  assumes "gtt_syms 𝒢 |⊆| ℱ"
  shows "RR2_spec (GTT_to_RR2_reg ℱ 𝒢) (ggtt_lang ℱ 𝒢)"
proof -
  have *: "snd ` (X × X) = X" for X by auto
  show ?thesis unfolding gtt_lang_from_agtt_lang GTT_to_RR2_reg_def RR2_spec_def
    parallel_closure_automaton[OF GTT_to_RR2_root, of ℱ 𝒢, unfolded RR2_spec_def]
  proof (intro arg_cong[where f = "λX. {gpair t u |t u. (t,u) ∈ X}"] equalityI subrelI, goal_cases)
    case (1 s t) then show ?case
      using subsetD[OF equalityD2[OF gtt_lang_from_agtt_lang], of "(s, t)" 𝒢]
      by (intro rev_image_eqI[of "(term_of_gterm s, term_of_gterm t)"])
         (auto simp: funas_term_of_gterm_conv subsetD[OF lift_root_step_mono]
           dest: subsetD[OF lift_root_step_sig[unfolded 𝒯G_equivalent_def, OF agtt_lang_syms[OF assms]]])
  next
    case (2 s t)
    from image_mono[OF agtt_lang_syms[OF assms], of snd, unfolded *]
    have *: "snd ` agtt_lang 𝒢 ⊆ gterms UNIV" by auto
    show ?case using 2
      by (auto intro!: lift_root_step_sig_transfer[unfolded 𝒯G_equivalent_def, OF _ *, of _ _ _ "fset ℱ"]
        simp: funas_gterm_gterm_of_term funas_term_of_gterm_conv)
  qed
qed


end

Theory FOL_Extra

theory FOL_Extra
  imports
    Type_Instances_Impl
    "FOL-Fitting.FOL_Fitting"
    "HOL-Library.FSet"
begin

section ‹Additional support for FOL-Fitting›
subsection ‹Iff›

definition Iff where
  "Iff p q = And (Impl p q) (Impl q p)"

lemma eval_Iff:
  "eval e f g (Iff p q) ⟷ (eval e f g p ⟷ eval e f g q)"
  by (auto simp: Iff_def)


subsection ‹Replacement of subformulas›

datatype ('a, 'b) ctxt
  = Hole
  | And1 "('a, 'b) ctxt" "('a, 'b) form"
  | And2 "('a, 'b) form" "('a, 'b) ctxt"
  | Or1 "('a, 'b) ctxt" "('a, 'b) form"
  | Or2 "('a, 'b) form" "('a, 'b) ctxt"
  | Impl1 "('a, 'b) ctxt" "('a, 'b) form"
  | Impl2 "('a, 'b) form" "('a, 'b) ctxt"
  | Neg1 "('a, 'b) ctxt"
  | Forall1 "('a, 'b) ctxt"
  | Exists1 "('a, 'b) ctxt"

primrec apply_ctxt :: "('a, 'b) ctxt ⇒ ('a, 'b) form ⇒ ('a, 'b) form" where
  "apply_ctxt Hole p = p"
| "apply_ctxt (And1 c v) p = And (apply_ctxt c p) v"
| "apply_ctxt (And2 u c) p = And u (apply_ctxt c p)"
| "apply_ctxt (Or1 c v) p = Or (apply_ctxt c p) v"
| "apply_ctxt (Or2 u c) p = Or u (apply_ctxt c p)"
| "apply_ctxt (Impl1 c v) p = Impl (apply_ctxt c p) v"
| "apply_ctxt (Impl2 u c) p = Impl u (apply_ctxt c p)"
| "apply_ctxt (Neg1 c) p = Neg (apply_ctxt c p)"
| "apply_ctxt (Forall1 c) p = Forall (apply_ctxt c p)"
| "apply_ctxt (Exists1 c) p = Exists (apply_ctxt c p)"

lemma replace_subformula:
  assumes "⋀e. eval e f g (Iff p q)"
  shows "eval e f g (Iff (apply_ctxt c p) (apply_ctxt c q))"
  by (induct c arbitrary: e) (auto simp: assms[unfolded eval_Iff] Iff_def)


subsection ‹Propositional identities›

lemma prop_ids:
  "eval e f g (Iff (And p q) (And q p))"
  "eval e f g (Iff (Or p q) (Or q p))"
  "eval e f g (Iff (Or p (Or q r)) (Or (Or p q) r))"
  "eval e f g (Iff (And p (And q r)) (And (And p q) r))"
  "eval e f g (Iff (Neg (Or p q)) (And (Neg p) (Neg q)))"
  "eval e f g (Iff (Neg (And p q)) (Or (Neg p) (Neg q)))"
  (* ... *)
  by (auto simp: Iff_def)


subsection ‹de Bruijn index manipulation for formulas; cf. @{term liftt}›

primrec liftti :: "nat ⇒ 'a term ⇒ 'a term" where
  "liftti i (Var j) = (if i > j then Var j else Var (Suc j))"
| "liftti i (App f ts) = App f (map (liftti i) ts)"

lemma liftts_def':
  "liftts ts = map liftt ts"
  by (induct ts) auto

text ‹@{term liftt} is a special case of @{term liftti}›
lemma lifttti_0:
  "liftti 0 t = liftt t"
  by (induct t) (auto simp: liftts_def')

primrec lifti :: "nat ⇒ ('a, 'b) form ⇒ ('a, 'b) form" where
  "lifti i FF = FF"
| "lifti i TT = TT"
| "lifti i (Pred b ts) = Pred b (map (liftti i) ts)"
| "lifti i (And p q) = And (lifti i p) (lifti i q)"
| "lifti i (Or p q) = Or (lifti i p) (lifti i q)"
| "lifti i (Impl p q) = Impl (lifti i p) (lifti i q)"
| "lifti i (Neg p) = Neg (lifti i p)"
| "lifti i (Forall p) = Forall (lifti (Suc i) p)"
| "lifti i (Exists p) = Exists (lifti (Suc i) p)"

abbreviation lift where
  "lift ≡ lifti 0"

text ‹interaction of @{term lifti} and @{term eval}›

lemma evalts_def':
  "evalts e f ts = map (evalt e f) ts"
  by (induct ts) auto

lemma evalt_liftti:
  "evalt (e⟨i:z⟩) f (liftti i t) = evalt e f t"
  by (induct t) (auto simp: evalts_def' cong: map_cong)

lemma eval_lifti [simp]:
  "eval (e⟨i:z⟩) f g (lifti i p) = eval e f g p"
  by (induct p arbitrary: e i) (auto simp: evalt_liftti evalts_def' comp_def)


subsection ‹Quantifier Identities›

lemma quant_ids:
  "eval e f g (Iff (Neg (Exists p)) (Forall (Neg p)))"
  "eval e f g (Iff (Neg (Forall p)) (Exists (Neg p)))"
  "eval e f g (Iff (And p (Forall q)) (Forall (And (lift p) q)))"
  "eval e f g (Iff (And p (Exists q)) (Exists (And (lift p) q)))"
  "eval e f g (Iff (Or p (Forall q)) (Forall (Or (lift p) q)))"
  "eval e f g (Iff (Or p (Exists q)) (Exists (Or (lift p) q)))"
  (* ... *)
  by (auto simp: Iff_def)

(* We'd need a bit of more machinery to deal with "∀x y. P(x,y) ⟷ ∀y x. P(x, y)":
 * swapping of de Bruijn indices (perhaps arbitrary permutation?) *) 


subsection ‹Function symbols and predicates, with arities.›

primrec predas_form :: "('a, 'b) form ⇒ ('b × nat) set" where
  "predas_form FF = {}"
| "predas_form TT = {}"
| "predas_form (Pred b ts) = {(b, length ts)}"
| "predas_form (And p q) = predas_form p ∪ predas_form q"
| "predas_form (Or p q) = predas_form p ∪ predas_form q"
| "predas_form (Impl p q) = predas_form p ∪ predas_form q"
| "predas_form (Neg p) = predas_form p"
| "predas_form (Forall p) = predas_form p"
| "predas_form (Exists p) = predas_form p"

primrec funas_term :: "'a term ⇒ ('a × nat) set" where
  "funas_term (Var x) = {}"
| "funas_term (App f ts) = {(f, length ts)} ∪ ⋃(set (map funas_term ts))"

primrec terms_form :: "('a, 'b) form ⇒ 'a term set" where
  "terms_form FF = {}"
| "terms_form TT = {}"
| "terms_form (Pred b ts) = set ts"
| "terms_form (And p q) = terms_form p ∪ terms_form q"
| "terms_form (Or p q) = terms_form p ∪ terms_form q"
| "terms_form (Impl p q) = terms_form p ∪ terms_form q"
| "terms_form (Neg p) = terms_form p"
| "terms_form (Forall p) = terms_form p"
| "terms_form (Exists p) = terms_form p"

definition funas_form :: "('a, 'b) form ⇒ ('a × nat) set" where
  "funas_form f ≡ ⋃(funas_term ` terms_form f)"


subsection ‹Negation Normal Form›

inductive is_nnf :: "('a, 'b) form ⇒ bool" where
  "is_nnf TT"
| "is_nnf FF"
| "is_nnf (Pred p ts)"
| "is_nnf (Neg (Pred p ts))"
| "is_nnf p ⟹ is_nnf q ⟹ is_nnf (And p q)"
| "is_nnf p ⟹ is_nnf q ⟹ is_nnf (Or p q)"
| "is_nnf p ⟹ is_nnf (Forall p)"
| "is_nnf p ⟹ is_nnf (Exists p)"

primrec nnf' :: "bool ⇒ ('a, 'b) form ⇒ ('a, 'b) form" where
  "nnf' b TT          = (if b then TT else FF)"
| "nnf' b FF          = (if b then FF else TT)"
| "nnf' b (Pred p ts) = (if b then id else Neg) (Pred p ts)"
| "nnf' b (And p q)   = (if b then And else Or) (nnf' b p) (nnf' b q)"
| "nnf' b (Or p q)    = (if b then Or else And) (nnf' b p) (nnf' b q)"
| "nnf' b (Impl p q)  = (if b then Or else And) (nnf' (¬ b) p) (nnf' b q)"
| "nnf' b (Neg p)     = nnf' (¬ b) p"
| "nnf' b (Forall p)  = (if b then Forall else Exists) (nnf' b p)"
| "nnf' b (Exists p)  = (if b then Exists else Forall) (nnf' b p)"

lemma eval_nnf':
  "eval e f g (nnf' b p) ⟷ (eval e f g p ⟷ b)"
  by (induct p arbitrary: e b) auto

lemma is_nnf_nnf':
  "is_nnf (nnf' b p)"
  by (induct p arbitrary: b) (auto intro: is_nnf.intros)

abbreviation nnf where
  "nnf ≡ nnf' True"

lemmas nnf_simpls [simp] = eval_nnf'[where b = True, unfolded eq_True] is_nnf_nnf'[where b = True]


subsection ‹Reasoning modulo ACI01›

datatype ('a, 'b) form_aci
  = TT_aci
  | FF_aci
  | Pred_aci bool 'b "'a term list"
  | And_aci "('a, 'b) form_aci fset"
  | Or_aci "('a, 'b) form_aci fset"
  | Forall_aci "('a, 'b) form_aci"
  | Exists_aci "('a, 'b) form_aci"

text ‹evaluation, see @{const eval}›

primrec eval_aci :: ‹(nat ⇒ 'c) ⇒ ('a ⇒ 'c list ⇒ 'c) ⇒
  ('b ⇒ 'c list ⇒ bool) ⇒ ('a, 'b) form_aci ⇒ bool› where
  "eval_aci e f g FF_aci            ⟷ False"
| "eval_aci e f g TT_aci            ⟷ True"
| "eval_aci e f g (Pred_aci b a ts) ⟷ (g a (evalts e f ts) ⟷ b)"
| "eval_aci e f g (And_aci ps)      ⟷ fBall (fimage (eval_aci e f g) ps) id"
| "eval_aci e f g (Or_aci ps)       ⟷ fBex (fimage (eval_aci e f g) ps) id"
| "eval_aci e f g (Forall_aci p)    ⟷ (∀z. eval_aci (e⟨0:z⟩) f g p)"
| "eval_aci e f g (Exists_aci p)    ⟷ (∃z. eval_aci (e⟨0:z⟩) f g p)"

text ‹smart constructor: conjunction›

fun and_aci where
  "and_aci FF_aci       _            = FF_aci"
| "and_aci _            FF_aci       = FF_aci"
| "and_aci TT_aci       q            = q"
| "and_aci p            TT_aci       = p"
| "and_aci (And_aci ps) (And_aci qs) = And_aci (ps |∪| qs)"
| "and_aci (And_aci ps) q            = And_aci (ps |∪| {|q|})"
| "and_aci p            (And_aci qs) = And_aci ({|p|} |∪| qs)"
| "and_aci p            q            = (if p = q then p else And_aci {|p,q|})"

lemma eval_and_aci [simp]:
  "eval_aci e f g (and_aci p q) ⟷ eval_aci e f g p ∧ eval_aci e f g q"
  by (cases "(p, q)" rule: and_aci.cases) (simp_all add: fBall_funion, meson+)

declare and_aci.simps [simp del]

text ‹smart constructor: disjunction›

fun or_aci where
  "or_aci TT_aci       _            = TT_aci"
| "or_aci _            TT_aci       = TT_aci"
| "or_aci FF_aci       q            = q"
| "or_aci p            FF_aci       = p"
| "or_aci (Or_aci ps)  (Or_aci qs)  = Or_aci (ps |∪| qs)"
| "or_aci (Or_aci ps)  q            = Or_aci (ps |∪| {|q|})"
| "or_aci p            (Or_aci qs)  = Or_aci ({|p|} |∪| qs)"
| "or_aci p            q            = (if p = q then p else Or_aci {|p,q|})"

lemma eval_or_aci [simp]:
  "eval_aci e f g (or_aci p q) ⟷ eval_aci e f g p ∨ eval_aci e f g q"
  by (cases "(p, q)" rule: or_aci.cases) (simp_all add: fBex_funion, meson+)

declare or_aci.simps [simp del]

text ‹convert negation normal form to ACIU01 normal form›

fun nnf_to_aci :: "('a, 'b) form ⇒ ('a, 'b) form_aci" where
  "nnf_to_aci FF                = FF_aci"
| "nnf_to_aci TT                = TT_aci"
| "nnf_to_aci (Pred b ts)       = Pred_aci True b ts"
| "nnf_to_aci (Neg (Pred b ts)) = Pred_aci False b ts"
| "nnf_to_aci (And p q)         = and_aci (nnf_to_aci p) (nnf_to_aci q)"
| "nnf_to_aci (Or p q)          = or_aci (nnf_to_aci p) (nnf_to_aci q)"
| "nnf_to_aci (Forall p)        = Forall_aci (nnf_to_aci p)"
| "nnf_to_aci (Exists p)        = Exists_aci (nnf_to_aci p)"
| "nnf_to_aci _                 = undefined" (* the remaining cases are impossible for NNFs *)

lemma eval_nnf_to_aci:
  "is_nnf p ⟹ eval_aci e f g (nnf_to_aci p) ⟷ eval e f g p"
  by (induct p arbitrary: e rule: is_nnf.induct) simp_all


subsection ‹A (mostly) Propositional Equivalence Check›

text ‹We reason modulo $\forall = \neg\exists\neg$, de Morgan, double negation, and
  ACUI01 of $\vee$ and $\wedge$, by converting to negation normal form, and then collapsing
  conjunctions and disjunctions taking units, absorption, commutativity, associativity, and
  idempotence into account. We only need soundness for a certifier.›

lemma check_equivalence_by_nnf_aci:
  "nnf_to_aci (nnf p) = nnf_to_aci (nnf q) ⟹ eval e f g p ⟷ eval e f g q"
  by (metis eval_nnf_to_aci is_nnf_nnf' eval_nnf')


subsection ‹Reasoning modulo ACI01›

datatype ('a, 'b) form_list_aci
  = TT_aci
  | FF_aci
  | Pred_aci bool 'b "'a term list"
  | And_aci "('a, 'b) form_list_aci list"
  | Or_aci "('a, 'b) form_list_aci list"
  | Forall_aci "('a, 'b) form_list_aci"
  | Exists_aci "('a, 'b) form_list_aci"

text ‹evaluation, see @{const eval}›

fun eval_list_aci :: ‹(nat ⇒ 'c) ⇒ ('a ⇒ 'c list ⇒ 'c) ⇒
  ('b ⇒ 'c list ⇒ bool) ⇒ ('a, 'b) form_list_aci ⇒ bool› where
  "eval_list_aci e f g FF_aci            ⟷ False"
| "eval_list_aci e f g TT_aci            ⟷ True"
| "eval_list_aci e f g (Pred_aci b a ts) ⟷ (g a (evalts e f ts) ⟷ b)"
| "eval_list_aci e f g (And_aci ps)      ⟷ list_all (λ fm. eval_list_aci e f g fm) ps"
| "eval_list_aci e f g (Or_aci ps)       ⟷ list_ex (λ fm. eval_list_aci e f g fm) ps"
| "eval_list_aci e f g (Forall_aci p)    ⟷ (∀z. eval_list_aci (e⟨0:z⟩) f g p)"
| "eval_list_aci e f g (Exists_aci p)    ⟷ (∃z. eval_list_aci (e⟨0:z⟩) f g p)"

text ‹smart constructor: conjunction›

fun and_list_aci where
  "and_list_aci FF_aci       _            = FF_aci"
| "and_list_aci _            FF_aci       = FF_aci"
| "and_list_aci TT_aci       q            = q"
| "and_list_aci p            TT_aci       = p"
| "and_list_aci (And_aci ps) (And_aci qs) = And_aci (remdups (ps @ qs))"
| "and_list_aci (And_aci ps) q            = And_aci (List.insert q ps)"
| "and_list_aci p            (And_aci qs) = And_aci (List.insert p qs)"
| "and_list_aci p            q            = (if p = q then p else And_aci [p,q])"

lemma eval_and_list_aci [simp]:
  "eval_list_aci e f g (and_list_aci p q) ⟷ eval_list_aci e f g p ∧ eval_list_aci e f g q"
  apply (cases "(p, q)" rule: and_list_aci.cases)
  apply (simp_all add: list.pred_set list_ex_iff)
  apply blast+
  done

declare and_list_aci.simps [simp del]

text ‹smart constructor: disjunction›

fun or_list_aci where
  "or_list_aci TT_aci       _            = TT_aci"
| "or_list_aci _            TT_aci       = TT_aci"
| "or_list_aci FF_aci       q            = q"
| "or_list_aci p            FF_aci       = p"
| "or_list_aci (Or_aci ps)  (Or_aci qs)  = Or_aci (remdups (ps @ qs))"
| "or_list_aci (Or_aci ps)  q            = Or_aci (List.insert q ps)"
| "or_list_aci p            (Or_aci qs)  = Or_aci (List.insert p qs)"
| "or_list_aci p            q            = (if p = q then p else Or_aci [p,q])"

lemma eval_or_list_aci [simp]:
  "eval_list_aci e f g (or_list_aci p q) ⟷ eval_list_aci e f g p ∨ eval_list_aci e f g q"
  by (cases "(p, q)" rule: or_list_aci.cases) (simp_all add: list.pred_set list_ex_iff, blast+)

declare or_list_aci.simps [simp del]

text ‹convert negation normal form to ACIU01 normal form›

fun nnf_to_list_aci :: "('a, 'b) form ⇒ ('a, 'b) form_list_aci" where
  "nnf_to_list_aci FF                = FF_aci"
| "nnf_to_list_aci TT                = TT_aci"
| "nnf_to_list_aci (Pred b ts)       = Pred_aci True b ts"
| "nnf_to_list_aci (Neg (Pred b ts)) = Pred_aci False b ts"
| "nnf_to_list_aci (And p q)         = and_list_aci (nnf_to_list_aci p) (nnf_to_list_aci q)"
| "nnf_to_list_aci (Or p q)          = or_list_aci (nnf_to_list_aci p) (nnf_to_list_aci q)"
| "nnf_to_list_aci (Forall p)        = Forall_aci (nnf_to_list_aci p)"
| "nnf_to_list_aci (Exists p)        = Exists_aci (nnf_to_list_aci p)"
| "nnf_to_list_aci _                 = undefined" (* the remaining cases are impossible for NNFs *)

lemma eval_nnf_to_list_aci:
  "is_nnf p ⟹ eval_list_aci e f g (nnf_to_list_aci p) ⟷ eval e f g p"
  by (induct p arbitrary: e rule: is_nnf.induct) simp_all

subsection ‹A (mostly) Propositional Equivalence Check›

text ‹We reason modulo $\forall = \neg\exists\neg$, de Morgan, double negation, and
  ACUI01 of $\vee$ and $\wedge$, by converting to negation normal form, and then collapsing
  conjunctions and disjunctions taking units, absorption, commutativity, associativity, and
  idempotence into account. We only need soundness for a certifier.›

derive linorder "term"
derive compare "term"
derive linorder form_list_aci
derive compare form_list_aci

fun ord_form_list_aci where
  "ord_form_list_aci TT_aci = TT_aci"
| "ord_form_list_aci FF_aci = FF_aci"
| "ord_form_list_aci (Pred_aci bool b ts) = Pred_aci bool b ts"
| "ord_form_list_aci (And_aci fm) = (And_aci (sort (map ord_form_list_aci fm)))"
| "ord_form_list_aci (Or_aci fm) = (Or_aci (sort (map ord_form_list_aci fm)))"
| "ord_form_list_aci (Forall_aci fm) = (Forall_aci (ord_form_list_aci fm))"
| "ord_form_list_aci (Exists_aci fm) = Exists_aci (ord_form_list_aci fm)"

lemma and_list_aci_simps:
  "and_list_aci TT_aci q = q"
  "and_list_aci q FF_aci = FF_aci"
  by (cases q, auto simp add: and_list_aci.simps)+

lemma ord_form_list_idemp:
  "ord_form_list_aci (ord_form_list_aci q) = ord_form_list_aci q"
  apply (induct q) apply (auto simp: list.set_map)
  apply (smt imageE list.set_map map_idI set_sort sorted_sort_id sorted_sort_key)+
  done

lemma eval_lsit_aci_ord_form_list_aci:
  "eval_list_aci e f g (ord_form_list_aci p) ⟷ eval_list_aci e f g p"
  by (induct p arbitrary: e) (auto simp: list.pred_set list_ex_iff)

lemma check_equivalence_by_nnf_sortedlist_aci:
  "ord_form_list_aci (nnf_to_list_aci (nnf p)) = ord_form_list_aci (nnf_to_list_aci (nnf q)) ⟹ eval e f g p ⟷ eval e f g q"
  by (metis eval_nnf_to_list_aci eval_lsit_aci_ord_form_list_aci is_nnf_nnf' eval_nnf')

hide_type (open) "term"
hide_const (open) Var
hide_type (open) ctxt

end
ody>

Theory FOR_Semantics

theory FOR_Semantics
  imports FOR_Certificate
    Lift_Root_Step
    "FOL-Fitting.FOL_Fitting"
begin

section ‹Semantics of Relations›

definition is_to_trs :: "('f, 'v) trs list ⇒ ftrs list ⇒ ('f, 'v) trs" where
  "is_to_trs Rs is = ⋃(set (map (case_ftrs ((!) Rs) ((`) prod.swap ∘ (!) Rs)) is))"

primrec eval_gtt_rel :: "('f × nat) set ⇒ ('f, 'v) trs list ⇒ ftrs gtt_rel ⇒ 'f gterm rel" where
  "eval_gtt_rel ℱ Rs (ARoot is) = Restr (grrstep (is_to_trs Rs is)) (𝒯G ℱ)"
| "eval_gtt_rel ℱ Rs (GInv g) = prod.swap ` (eval_gtt_rel ℱ Rs g)"
| "eval_gtt_rel ℱ Rs (AUnion g1 g2) = (eval_gtt_rel ℱ Rs g1) ∪ (eval_gtt_rel ℱ Rs g2)"
| "eval_gtt_rel ℱ Rs (ATrancl g) = (eval_gtt_rel ℱ Rs g)+"
| "eval_gtt_rel ℱ Rs (AComp g1 g2) = (eval_gtt_rel ℱ Rs g1) O (eval_gtt_rel ℱ Rs g2)"
| "eval_gtt_rel ℱ Rs (GTrancl g) = gtrancl_rel ℱ (eval_gtt_rel ℱ Rs g)"
| "eval_gtt_rel ℱ Rs (GComp g1 g2) =  gcomp_rel ℱ (eval_gtt_rel ℱ Rs g1) (eval_gtt_rel ℱ Rs g2)"

primrec eval_rr1_rel :: "('f × nat) set ⇒ ('f, 'v) trs list ⇒ ftrs rr1_rel ⇒ 'f gterm set"
  and eval_rr2_rel :: "('f × nat) set ⇒ ('f, 'v) trs list ⇒ ftrs rr2_rel ⇒ 'f gterm rel" where
  "eval_rr1_rel ℱ Rs R1Terms = (𝒯G ℱ)"
| "eval_rr1_rel ℱ Rs (R1Union R S) = (eval_rr1_rel ℱ Rs R) ∪ (eval_rr1_rel ℱ Rs S)"
| "eval_rr1_rel ℱ Rs (R1Inter R S) = (eval_rr1_rel ℱ Rs R) ∩ (eval_rr1_rel ℱ Rs S)"
| "eval_rr1_rel ℱ Rs (R1Diff R S) = (eval_rr1_rel ℱ Rs R) - (eval_rr1_rel ℱ Rs S)"
| "eval_rr1_rel ℱ Rs (R1Proj n R) = (case n of 0 ⇒ fst ` (eval_rr2_rel ℱ Rs R)
                                             | _ ⇒ snd ` (eval_rr2_rel ℱ Rs R))"
| "eval_rr1_rel ℱ Rs (R1NF is) = NF (Restr (grstep (is_to_trs Rs is)) (𝒯G ℱ)) ∩ (𝒯G ℱ)"
| "eval_rr1_rel ℱ Rs (R1Inf R) = {s. infinite (eval_rr2_rel ℱ Rs R `` {s})}"
| "eval_rr2_rel ℱ Rs (R2GTT_Rel A W X) = lift_root_step ℱ W X (eval_gtt_rel ℱ Rs A)"
| "eval_rr2_rel ℱ Rs (R2Inv R) = prod.swap ` (eval_rr2_rel ℱ Rs R)"
| "eval_rr2_rel ℱ Rs (R2Union R S) = (eval_rr2_rel ℱ Rs R) ∪ (eval_rr2_rel ℱ Rs S)"
| "eval_rr2_rel ℱ Rs (R2Inter R S) = (eval_rr2_rel ℱ Rs R) ∩ (eval_rr2_rel ℱ Rs S)"
| "eval_rr2_rel ℱ Rs (R2Diff R S) = (eval_rr2_rel ℱ Rs R) - (eval_rr2_rel ℱ Rs S)"
| "eval_rr2_rel ℱ Rs (R2Comp R S) = (eval_rr2_rel ℱ Rs R) O (eval_rr2_rel ℱ Rs S)"
| "eval_rr2_rel ℱ Rs (R2Diag R) = Id_on (eval_rr1_rel ℱ Rs R)"
| "eval_rr2_rel ℱ Rs (R2Prod R S) = (eval_rr1_rel ℱ Rs R) × (eval_rr1_rel ℱ Rs S)"


subsection ‹Semantics of Formulas›

fun eval_formula ::  "('f × nat) set ⇒ ('f, 'v) trs list ⇒ (nat ⇒ 'f gterm) ⇒
  ftrs formula ⇒ bool" where
  "eval_formula ℱ Rs α (FRR1 r1 x) ⟷ α x ∈ eval_rr1_rel ℱ Rs r1"
| "eval_formula ℱ Rs α (FRR2 r2 x y) ⟷ (α x, α y) ∈ eval_rr2_rel ℱ Rs r2"
| "eval_formula ℱ Rs α (FAnd fs) ⟷ (∀f ∈ set fs. eval_formula ℱ Rs α f)"
| "eval_formula ℱ Rs α (FOr fs) ⟷ (∃f ∈ set fs. eval_formula ℱ Rs α f)"
| "eval_formula ℱ Rs α (FNot f) ⟷ ¬ eval_formula ℱ Rs α f"
| "eval_formula ℱ Rs α (FExists f) ⟷ (∃z ∈ 𝒯G ℱ. eval_formula ℱ Rs (α⟨0 : z⟩) f)"
| "eval_formula ℱ Rs α (FForall f) ⟷ (∀z ∈ 𝒯G ℱ. eval_formula ℱ Rs (α⟨0 : z⟩) f)"

fun formula_arity :: "'trs formula ⇒ nat" where
  "formula_arity (FRR1 r1 x) = Suc x"
| "formula_arity (FRR2 r2 x y) = max (Suc x) (Suc y)"
| "formula_arity (FAnd fs) = max_list (map formula_arity fs)"
| "formula_arity (FOr fs) = max_list (map formula_arity fs)"
| "formula_arity (FNot f) = formula_arity f"
| "formula_arity (FExists f) = formula_arity f - 1"
| "formula_arity (FForall f) = formula_arity f - 1"



lemma R1NF_reps:
  assumes "funas_trs R ⊆ ℱ" "∀ t. (term_of_gterm s, term_of_gterm t) ∈ rstep R ⟶ ¬funas_gterm t ⊆ ℱ"
    and "funas_gterm s ⊆ ℱ" "(l, r) ∈ R" "term_of_gterm s = C⟨l ⋅ (σ  :: 'b ⇒ ('a, 'b) Term.term)⟩"
  shows False
proof -
  obtain c where w: "funas_term (c :: ('a, 'b) Term.term) ⊆ ℱ" "ground c"
    using assms(3) funas_term_of_gterm_conv ground_term_of_gterm by blast
  define τ where "τ x = (if x ∈ vars_term l then σ x else c)" for x
  from assms(4-) have terms: "term_of_gterm s = C⟨l ⋅ τ⟩" "(C⟨l ⋅ τ⟩, C⟨r ⋅ τ⟩) ∈ rstep R"
    using τ_def by auto (metis term_subst_eq)
  from this(1) have [simp]: "funas_gterm s = funas_term C⟨l ⋅ τ⟩" by (metis funas_term_of_gterm_conv)
  from w assms(1, 3, 4) have [simp]: "funas_term C⟨r ⋅ τ⟩ ⊆ ℱ" using τ_def
    by (auto simp: funas_trs_def funas_term_subst)
  moreover have "ground C⟨r ⋅ τ⟩" using terms(1) w τ_def
    by (auto intro!: ground_substI) (metis term_of_gterm_ctxt_subst_apply_ground)
  ultimately show ?thesis using assms(2) terms(2)
    by (metis funas_term_of_gterm_conv ground_term_to_gtermD terms(1))
qed


text ‹The central property we are interested in is satisfiability›

definition formula_satisfiable where
  "formula_satisfiable ℱ Rs f ⟷ (∃α. range α ⊆ 𝒯G ℱ ∧ eval_formula ℱ Rs α f)"

subsection ‹Validation›

subsection ‹Defining properties of @{const gcomp_rel} and @{const gtrancl_rel}›

lemma gcomp_rel_sig:
  assumes "R ⊆ 𝒯G ℱ × 𝒯G ℱ" and "S ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "gcomp_rel ℱ R S ⊆ 𝒯G ℱ × 𝒯G ℱ"
  using assms subsetD[OF signature_pres_funas_cl(2)[OF assms(1)]]
  by (auto simp: gcomp_rel_def lift_root_step.simps gmctxt_cl_gmctxtex_onp_conv) (metis refl_onD2 relf_on_gmctxtcl_funas)

lemma gtrancl_rel_sig:
  assumes "R ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "gtrancl_rel ℱ R ⊆ 𝒯G ℱ × 𝒯G ℱ"
  using gtrancl_rel_sound[OF assms] by simp

lemma gtrancl_rel:
  assumes "R ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "lift_root_step ℱ PAny EStrictParallel (gtrancl_rel ℱ R) = (lift_root_step ℱ PAny ESingle R)+"
  unfolding lift_root_step.simps using gmctxtcl_funas_strict_gtrancl_rel[OF assms] .

lemma gtrancl_rel':
  assumes "R ⊆ 𝒯G ℱ × 𝒯G ℱ"
  shows "lift_root_step ℱ PAny EParallel (gtrancl_rel ℱ R) = Restr ((lift_root_step ℱ PAny ESingle R)*) (𝒯G ℱ)"
  using assms gtrancl_rel[OF assms]
  by (auto simp: lift_root_step_Parallel_conv
      simp flip: reflcl_trancl dest: Restr_simps(5)[OF lift_root_step_sig, THEN subsetD])

text ‹GTT relation semantics respects the signature›

lemma eval_gtt_rel_sig:
  "eval_gtt_rel ℱ Rs g ⊆ 𝒯G ℱ × 𝒯G ℱ"
proof -
  show ?thesis by (induct g) (auto 0 3 simp: gtrancl_rel_sig gcomp_rel_sig dest: tranclD tranclD2)
qed

text ‹RR1 and RR2 relation semantics respect the signature›

lemma eval_rr12_rel_sig:
  "eval_rr1_rel ℱ Rs r1 ⊆ 𝒯G ℱ"
  "eval_rr2_rel ℱ Rs r2 ⊆ 𝒯G ℱ × 𝒯G ℱ"
proof (induct r1 and r2)
  case (R1Inf r2) then show ?case by (auto dest!: infinite_imp_nonempty)
next
  case (R1Proj i r2) then show ?case by (fastforce split: nat.splits)
next
  case (R2GTT_Rel g W X) then show ?case by (simp add: lift_root_step_sig eval_gtt_rel_sig)
qed auto


subsection ‹Correctness of derived constructions›

lemma R1Fin:
  "eval_rr1_rel ℱ Rs (R1Fin r) = {t ∈ 𝒯G ℱ. finite {s. (t, s) ∈ eval_rr2_rel ℱ Rs r}}"
  by (auto simp: R1Fin_def Image_def)

lemma R2Eq:
  "eval_rr2_rel ℱ Rs R2Eq = Id_on (𝒯G ℱ)"
  by (auto simp: 𝒯G_funas_gterm_conv R2Eq_def)

lemma R2Reflc:
  "eval_rr2_rel ℱ Rs (R2Reflc r) = eval_rr2_rel ℱ Rs r ∪ Id_on (𝒯G ℱ)"
  "eval_rr2_rel ℱ Rs (R2Reflc r) = Restr ((eval_rr2_rel ℱ Rs r)=) (𝒯G ℱ)"
  using eval_rr12_rel_sig(2)[of ℱ Rs "R2Reflc r"]
  by (auto simp: R2Reflc_def R2Eq)

lemma R2Step:
  "eval_rr2_rel ℱ Rs (R2Step ts) = Restr (grstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  by (auto simp: lift_root_step.simps R2Step_def grstep_lift_root_step grrstep_subst_cl_conv grstepD_grstep_conv grstepD_def)

lemma R2StepEq:
  "eval_rr2_rel ℱ Rs (R2StepEq ts) = Restr ((grstep (is_to_trs Rs ts))=) (𝒯G ℱ)"
  by (auto simp: R2StepEq_def R2Step R2Reflc(2))

lemma R2Steps:
  fixes ℱ Rs ts defines "R ≡ Restr (grstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  shows "eval_rr2_rel ℱ Rs (R2Steps ts) = R+"
  by (simp add: R2Steps_def GSteps_def R_def gtrancl_rel grstep_lift_root_step)
     (metis FOR_Semantics.gtrancl_rel Sigma_cong grstep_lift_root_step inf.cobounded2 lift_root_Any_EStrict_eq)

lemma R2StepsEq:
  fixes ℱ Rs ts defines "R ≡ Restr (grstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  shows "eval_rr2_rel ℱ Rs (R2StepsEq ts) = Restr (R*) (𝒯G ℱ)"
  using R2Steps[of ℱ Rs ts]
  by (simp add: R2StepsEq_def R2Steps_def lift_root_step_Parallel_conv Int_Un_distrib2 R_def Restr_simps flip: reflcl_trancl)

lemma R2StepsNF:
  fixes ℱ Rs ts defines "R ≡ Restr (grstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  shows "eval_rr2_rel ℱ Rs (R2StepsNF ts) = Restr (R* ∩ UNIV × NF R) (𝒯G ℱ)"
  using R2StepsEq[of ℱ Rs ts]
  by (auto simp: R2StepsNF_def R2StepsEq_def R_def)

lemma R2ParStep:
  "eval_rr2_rel ℱ Rs (R2ParStep ts) = Restr (gpar_rstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  by (simp add: R2ParStep_def gar_rstep_lift_root_step)

lemma R2RootStep:
  "eval_rr2_rel ℱ Rs (R2RootStep ts) = Restr (grrstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  by (simp add: R2RootStep_def lift_root_step.simps)

lemma R2RootStepEq:
  "eval_rr2_rel ℱ Rs (R2RootStepEq ts) = Restr ((grrstep (is_to_trs Rs ts))=) (𝒯G ℱ)"
  by (auto simp: R2RootStepEq_def R2RootStep R2Reflc(2))

lemma R2RootSteps:
  fixes ℱ Rs ts defines "R ≡ Restr (grrstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  shows "eval_rr2_rel ℱ Rs (R2RootSteps ts) = R+"
  by (simp add: R2RootSteps_def R_def lift_root_step.simps)

lemma R2RootStepsEq:
  fixes ℱ Rs ts defines "R ≡ Restr (grrstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  shows "eval_rr2_rel ℱ Rs (R2RootStepsEq ts) = Restr (R*) (𝒯G ℱ)"
  by (auto simp: R2RootStepsEq_def R2Reflc_def R2RootSteps R_def R2Eq_def Int_Un_distrib2 Restr_simps simp flip: reflcl_trancl)

lemma R2NonRootStep:
  "eval_rr2_rel ℱ Rs (R2NonRootStep ts) = Restr (gnrrstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  by (simp add: R2NonRootStep_def grrstep_lift_root_gnrrstep)

lemma R2NonRootStepEq:
  "eval_rr2_rel ℱ Rs (R2NonRootStepEq ts) = Restr ((gnrrstep (is_to_trs Rs ts))=) (𝒯G ℱ)"
  by (auto simp: R2NonRootStepEq_def R2Reflc_def R2Eq_def R2NonRootStep Int_Un_distrib2)

lemma R2NonRootSteps:
  fixes ℱ Rs ts defines "R ≡ Restr (gnrrstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  shows "eval_rr2_rel ℱ Rs (R2NonRootSteps ts) = R+"
  apply (simp add: lift_root_step.simps gnrrstepD_gnrrstep_conv gnrrstepD_def
    grrstep_subst_cl_conv R2NonRootSteps_def R_def GSteps_def lift_root_step_Parallel_conv)
  apply (intro gmctxtex_funas_nroot_strict_gtrancl_rel)
  by simp

lemma R2NonRootStepsEq:
  fixes ℱ Rs ts defines "R ≡ Restr (gnrrstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  shows "eval_rr2_rel ℱ Rs (R2NonRootStepsEq ts) = Restr (R*) (𝒯G ℱ)"
  using R2NonRootSteps[of ℱ Rs ts]
  by (simp add: R2NonRootSteps_def R2NonRootStepsEq_def lift_root_step_Parallel_conv
    R_def Int_Un_distrib2 Restr_simps flip: reflcl_trancl)

lemma converse_to_prod_swap:
  "R¯ = prod.swap ` R"
  by auto

lemma R2Meet:
  fixes ℱ Rs ts defines "R ≡ Restr (grstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  shows "eval_rr2_rel ℱ Rs (R2Meet ts) = Restr ((R¯)* O R*) (𝒯G ℱ)"
  apply (simp add: R2Meet_def R_def GSteps_def converse_to_prod_swap gcomp_rel[folded lift_root_step.simps] gtrancl_rel' swap_lift_root_step grstep_lift_root_step)
  apply (simp add: Restr_simps converse_Int converse_Un converse_Times Int_Un_distrib2 flip: reflcl_trancl trancl_converse converse_to_prod_swap)
  done

lemma R2Join:
  fixes ℱ Rs ts defines "R ≡ Restr (grstep (is_to_trs Rs ts)) (𝒯G ℱ)"
  shows "eval_rr2_rel ℱ Rs (R2Join ts) = Restr (R* O (R¯)*) (𝒯G ℱ)"
  apply (simp add: R2Join_def R_def GSteps_def converse_to_prod_swap  gcomp_rel[folded lift_root_step.simps] gtrancl_rel' swap_lift_root_step grstep_lift_root_step)
  apply (simp add: Restr_simps converse_to_prod_swap[symmetric] converse_Int converse_Un converse_Times Int_Un_distrib2 flip: reflcl_trancl trancl_converse)
  done

end

Theory FOR_Check

theory FOR_Check
  imports
    FOR_Semantics
    FOL_Extra
    GTT_RRn
    First_Order_Terms.Option_Monad
    LV_to_GTT
    NF
    Regular_Tree_Relations.GTT_Transitive_Closure
    Regular_Tree_Relations.AGTT
    Regular_Tree_Relations.RR2_Infinite_Q_infinity
    Regular_Tree_Relations.RRn_Automata
begin

section ‹Check inference steps›

type_synonym ('f, 'v) fin_trs  = "('f, 'v) rule fset"

lemma tl_drop_conv:
  "tl xs = drop 1 xs"
  by (induct xs) auto

definition rrn_drop_fst where
  "rrn_drop_fst 𝒜 = relabel_reg (trim_reg (collapse_automaton_reg (fmap_funs_reg (drop_none_rule 1) (trim_reg 𝒜))))"

lemma rrn_drop_fst_lang:
  assumes "RRn_spec n A T" "1 < n"
  shows "RRn_spec (n - 1) (rrn_drop_fst A) (drop 1 ` T)"
  using drop_automaton_reg[OF _ assms(2), of "trim_reg A" T] assms(1)
  unfolding rrn_drop_fst_def
  by (auto simp: trim_ta_reach)


definition liftO1 :: "('a ⇒ 'b) ⇒ 'a option ⇒ 'b option" where
  "liftO1 = map_option"

definition liftO2 :: "('a ⇒ 'b ⇒ 'c) ⇒ 'a option ⇒ 'b option ⇒ 'c option" where
  "liftO2 f a b = case_option None (λa'. liftO1 (f a') b) a"

lemma liftO1_Some [simp]:
  "liftO1 f x = Some y ⟷ (∃x'. x = Some x') ∧ y = f (the x)"
  by (cases x) (auto simp: liftO1_def)

lemma liftO2_Some [simp]:
  "liftO2 f x y = Some z ⟷ (∃x' y'. x = Some x' ∧ y = Some y') ∧ z = f (the x) (the y)"
  by (cases x; cases y) (auto simp: liftO2_def)

subsection ‹Computing TRSs›

lemma is_to_trs_props:
  assumes "∀ R ∈ set Rs. finite R ∧ lv_trs R ∧ funas_trs R ⊆ ℱ" "∀i ∈ set is. case_ftrs id id i < length Rs"
  shows "funas_trs (is_to_trs Rs is) ⊆ ℱ" "lv_trs (is_to_trs Rs is)" "finite (is_to_trs Rs is)"
proof (goal_cases ℱ lv fin)
  case ℱ show ?case using assms nth_mem
    apply (auto simp: is_to_trs_def funas_trs_def case_prod_beta split: ftrs.splits)
     apply fastforce
    apply (metis (no_types, lifting) assms(1) in_mono rhs_wf)
    apply (metis (no_types, lifting) assms(1) in_mono rhs_wf)
    by (smt (z3) UN_subset_iff fst_conv in_mono le_sup_iff)
qed (insert assms, (fastforce simp: is_to_trs_def funas_trs_def lv_trs_def split: ftrs.splits)+)


definition is_to_fin_trs :: "('f, 'v) fin_trs list ⇒ ftrs list ⇒ ('f, 'v) fin_trs" where
  "is_to_fin_trs Rs is = |⋃|  (fset_of_list (map (case_ftrs ((!) Rs) ((|`|) prod.swap ∘ (!) Rs)) is))"


lemma is_to_fin_trs_conv:
  assumes "∀i ∈ set is. case_ftrs id id i < length Rs"
  shows "is_to_trs (map fset Rs) is = fset (is_to_fin_trs Rs is)"
  using assms unfolding is_to_trs_def is_to_fin_trs_def
  by (auto simp: ffUnion.rep_eq fset_of_list.rep_eq split: ftrs.splits)

definition is_to_trs' :: "('f, 'v) fin_trs list ⇒ ftrs list ⇒ ('f, 'v) fin_trs option" where
  "is_to_trs' Rs is = do {
    guard (∀i ∈ set is. case_ftrs id id i < length Rs);
    Some (is_to_fin_trs Rs is)
  }"

lemma is_to_trs_conv:
  "is_to_trs' Rs is = Some S ⟹ is_to_trs (map fset Rs) is = fset S"
  using is_to_fin_trs_conv unfolding is_to_trs'_def
  by (auto simp add: guard_simps split: bind_splits)

lemma is_to_trs'_props:
  assumes "∀ R ∈ set Rs. lv_trs (fset R) ∧ ffunas_trs R |⊆| ℱ" and "is_to_trs' Rs is = Some S"
  shows "ffunas_trs S |⊆| ℱ" "lv_trs (fset S)"
proof -
  from assms(2) have well: "∀i ∈ set is. case_ftrs id id i < length Rs" "is_to_fin_trs Rs is = S"
    unfolding is_to_trs'_def
    by (auto simp add: guard_simps split: bind_splits)
  have "∀ R ∈ set Rs. finite (fset R) ∧ lv_trs (fset R) ∧ funas_trs (fset R) ⊆ (fset ℱ)"
    using assms(1) by (auto simp: ffunas_trs.rep_eq less_eq_fset.rep_eq)
  from is_to_trs_props[of "map fset Rs" "fset ℱ" "is"] this well(1)
  have "lv_trs (is_to_trs (map fset Rs) is)" "funas_trs (is_to_trs (map fset Rs) is) ⊆ fset ℱ"
    by auto
  then show "lv_trs (fset S)" "ffunas_trs S |⊆| ℱ"
    using is_to_fin_trs_conv[OF well(1)] unfolding well(2)
    by (auto simp: ffunas_trs.rep_eq less_eq_fset.rep_eq)
qed

subsection ‹Computing GTTs›

fun gtt_of_gtt_rel :: "('f × nat) fset ⇒ ('f :: linorder, 'v) fin_trs list ⇒ ftrs gtt_rel ⇒ (nat, 'f) gtt option" where
  "gtt_of_gtt_rel ℱ Rs (ARoot is) = liftO1 (λR. relabel_gtt (agtt_grrstep R ℱ)) (is_to_trs' Rs is)"
| "gtt_of_gtt_rel ℱ Rs (GInv g) = liftO1 prod.swap (gtt_of_gtt_rel ℱ Rs g)"
| "gtt_of_gtt_rel ℱ Rs (AUnion g1 g2) = liftO2 (λg1 g2. relabel_gtt (AGTT_union' g1 g2)) (gtt_of_gtt_rel ℱ Rs g1) (gtt_of_gtt_rel ℱ Rs g2)"
| "gtt_of_gtt_rel ℱ Rs (ATrancl g) = liftO1 (relabel_gtt ∘ AGTT_trancl) (gtt_of_gtt_rel ℱ Rs g)"
| "gtt_of_gtt_rel ℱ Rs (GTrancl g) = liftO1 GTT_trancl (gtt_of_gtt_rel ℱ Rs g)"
| "gtt_of_gtt_rel ℱ Rs (AComp g1 g2) = liftO2 (λg1 g2. relabel_gtt (AGTT_comp' g1 g2)) (gtt_of_gtt_rel ℱ Rs g1) (gtt_of_gtt_rel ℱ Rs g2)"
| "gtt_of_gtt_rel ℱ Rs (GComp g1 g2) = liftO2 (λg1 g2. relabel_gtt (GTT_comp' g1 g2)) (gtt_of_gtt_rel ℱ Rs g1) (gtt_of_gtt_rel ℱ Rs g2)"


lemma gtt_of_gtt_rel_correct:
  assumes "∀R ∈ set Rs. lv_trs (fset R) ∧ ffunas_trs R |⊆| ℱ"
  shows "gtt_of_gtt_rel ℱ Rs g = Some g' ⟹ agtt_lang g' = eval_gtt_rel (fset ℱ) (map fset Rs) g"
proof (induct g arbitrary: g')
  note [simp] = bind_eq_Some_conv guard_simps
  have proj_sq: "fst ` (X × X) = X" "snd ` (X × X) = X" for X by auto
{
  case (ARoot "is")
  then obtain w where w:"is_to_trs' Rs is = Some w" by auto
  then show ?case using ARoot is_to_trs'_props[OF assms w] is_to_trs_conv[OF w]
    using agtt_grrstep 
    by auto
next
  case (GInv g) then show ?case by (simp add: agtt_lang_swap gtt_states_def)
next
  case (AUnion g1 g2)
  from AUnion(3)[simplified, THEN conjunct1] AUnion(3)[simplified, THEN conjunct2, THEN conjunct1]
  obtain w1 w2 where
    [simp]: "gtt_of_gtt_rel ℱ Rs g1 = Some w1" "gtt_of_gtt_rel ℱ Rs g2 = Some w2"
    by blast
  then show ?case using AUnion(3)
    by (simp add: AGTT_union'_sound AUnion)
next
  case (ATrancl g)
  from ATrancl[simplified] obtain w1 where
    [simp]: "gtt_of_gtt_rel ℱ Rs g = Some w1" "g' = relabel_gtt (AGTT_trancl w1)" by auto
  then have fin_lang: "eval_gtt_rel (fset ℱ) (map fset Rs) g = agtt_lang w1"
    using ATrancl by auto
  from fin_lang show ?case using AGTT_trancl_sound[of w1]
    by auto
next
  case (GTrancl g) note * = GTrancl(2)[simplified, THEN conjunct2]
  show ?case unfolding gtt_of_gtt_rel.simps GTT_trancl_alang * gtrancl_rel_def eval_gtt_rel.simps gmctxt_cl_gmctxtex_onp_conv
  proof ((intro conjI equalityI subrelI; (elim relcompE)?), goal_cases LR RL)
    case (LR _ _ s _ z s' t' t)
    show ?case using lift_root_steps_sig_transfer'[OF LR(2)[folded lift_root_step.simps], of "fset ℱ"]
      lift_root_steps_sig_transfer[OF LR(5)[folded lift_root_step.simps], of "fset ℱ"]
      image_mono[OF eval_gtt_rel_sig[of "fset ℱ" "map fset Rs" g], of fst, unfolded proj_sq]
      image_mono[OF eval_gtt_rel_sig[of "fset ℱ" "map fset Rs" g], of snd, unfolded proj_sq]
      subsetD[OF eval_gtt_rel_sig[of "fset ℱ" "map fset Rs" g]] LR(1, 3, 4) GTrancl
      by (intro relcompI[OF _ relcompI, of _ s' _ t' _])
         (auto simp: 𝒯G_funas_gterm_conv lift_root_step.simps)
  next
    case (RL _ _ s _ z s' t' t)
    then show ?case using GTrancl
      lift_root_step_mono[of "fset ℱ" UNIV PAny ESingle "eval_gtt_rel (fset ℱ) (map fset Rs) g", THEN rtrancl_mono]
      unfolding lift_root_step.simps[symmetric]
      by (intro relcompI[OF _ relcompI, of _ s' _ t' _])
         (auto simp: 𝒯G_funas_gterm_conv lift_root_step_mono trancl_mono)
  qed
next
  case (AComp g1 g2)
  from AComp[simplified] obtain w1 w2 where
    [simp]: "gtt_of_gtt_rel ℱ Rs g1 = Some w1" "gtt_of_gtt_rel ℱ Rs g2 = Some w2"
            "g' = relabel_gtt (AGTT_comp' w1 w2)" by auto
  then have fin_lang: "eval_gtt_rel (fset ℱ) (map fset Rs) g1 = agtt_lang w1"
    "eval_gtt_rel (fset ℱ) (map fset Rs) g2 = agtt_lang w2"
    using AComp by auto
  from fin_lang AGTT_comp'_sound[of w1 w2]
  show ?case by simp
next
  case (GComp g1 g2)
  let ?r = "λ g. eval_gtt_rel (fset ℱ) (map fset Rs) g"
  have *: "gmctxtex_onp (λC. True) (?r g1) = lift_root_step UNIV PAny EParallel (?r g1)"
    "gmctxtex_onp (λC. True) (?r g2) = lift_root_step UNIV PAny EParallel (?r g2)"
    by (auto simp: lift_root_step.simps)
  show ?case using GComp(3)
    apply (intro conjI equalityI subrelI; simp add: gmctxt_cl_gmctxtex_onp_conv GComp(1,2) gtt_comp'_alang gcomp_rel_def * flip: lift_root_step.simps; elim conjE disjE exE relcompE)
    subgoal for s t _ _ _ _ _ u
      using image_mono[OF eval_gtt_rel_sig, of snd "fset ℱ" "map fset Rs", unfolded proj_sq]
      apply (subst relcompI[of _ u "eval_gtt_rel _ _ g1", OF _ lift_root_step_sig_transfer[of _ UNIV PAny EParallel "_ g2" "fset ℱ"]])
      apply (force simp add: subsetI 𝒯G_equivalent_def)+
      done
    subgoal for s t _ _ _ _ _ u
      using image_mono[OF eval_gtt_rel_sig, of fst "fset ℱ" "map fset Rs", unfolded proj_sq]
      apply (subst relcompI[of _ u _ _ "eval_gtt_rel _ _ g2", OF lift_root_step_sig_transfer'[of _ UNIV PAny EParallel "_ g1" "fset ℱ"]])
      apply (force simp add: subsetI 𝒯G_equivalent_def)+
      done
    by (auto intro: subsetD[OF lift_root_step_mono[of "fset ℱ" UNIV]])
}
qed


subsection ‹Computing RR1 and RR2 relations›

definition "simplify_reg 𝒜 = (relabel_reg (trim_reg 𝒜))"

lemma ℒ_simplify_reg [simp]: "ℒ (simplify_reg 𝒜) = ℒ 𝒜"
  by (simp add: simplify_reg_def ℒ_trim)

lemma RR1_spec_simplify_reg[simp]:
  "RR1_spec (simplify_reg 𝒜) R = RR1_spec 𝒜 R"
  by (auto simp: RR1_spec_def)
lemma RR2_spec_simplify_reg[simp]:
  "RR2_spec (simplify_reg 𝒜) R = RR2_spec 𝒜 R"
  by (auto simp: RR2_spec_def)
lemma RRn_spec_simplify_reg[simp]:
  "RRn_spec n (simplify_reg 𝒜) R = RRn_spec n 𝒜 R"
  by (auto simp: RRn_spec_def)

lemma RR1_spec_eps_free_reg[simp]:
  "RR1_spec (eps_free_reg 𝒜) R = RR1_spec 𝒜 R"
  by (auto simp: RR1_spec_def ℒ_eps_free)
lemma RR2_spec_eps_free_reg[simp]:
  "RR2_spec (eps_free_reg 𝒜) R = RR2_spec 𝒜 R"
  by (auto simp: RR2_spec_def ℒ_eps_free)
lemma RRn_spec_eps_free_reg[simp]:
  "RRn_spec n (eps_free_reg 𝒜) R = RRn_spec n 𝒜 R"
  by (auto simp: RRn_spec_def ℒ_eps_free)

fun rr1_of_rr1_rel :: "('f × nat) fset ⇒ ('f :: linorder, 'v) fin_trs list ⇒ ftrs rr1_rel ⇒ (nat, 'f) reg option"
and rr2_of_rr2_rel :: "('f × nat) fset ⇒ ('f, 'v) fin_trs list ⇒ ftrs rr2_rel ⇒ (nat, 'f option × 'f option) reg option" where
  "rr1_of_rr1_rel ℱ Rs R1Terms = Some (relabel_reg (term_reg ℱ))"
| "rr1_of_rr1_rel ℱ Rs (R1NF is) = liftO1 (λR. (simplify_reg (nf_reg (fst |`| R) ℱ))) (is_to_trs' Rs is)"
| "rr1_of_rr1_rel ℱ Rs (R1Inf r) = liftO1 (λR.
    let 𝒜 = trim_reg R in
    simplify_reg (proj_1_reg (Inf_reg_impl 𝒜))
  ) (rr2_of_rr2_rel ℱ Rs r)"
| "rr1_of_rr1_rel ℱ Rs (R1Proj i r) = (case i of 0 ⇒
      liftO1 (trim_reg ∘ proj_1_reg) (rr2_of_rr2_rel ℱ Rs r)
    | _ ⇒ liftO1 (trim_reg ∘ proj_2_reg) (rr2_of_rr2_rel ℱ Rs r))"
| "rr1_of_rr1_rel ℱ Rs (R1Union s1 s2) =
    liftO2 (λ x y. relabel_reg (reg_union x y)) (rr1_of_rr1_rel ℱ Rs s1) (rr1_of_rr1_rel ℱ Rs s2)"
| "rr1_of_rr1_rel ℱ Rs (R1Inter s1 s2) =
    liftO2 (λ x y. simplify_reg (reg_intersect x y)) (rr1_of_rr1_rel ℱ Rs s1) (rr1_of_rr1_rel ℱ Rs s2)"
| "rr1_of_rr1_rel ℱ Rs (R1Diff s1 s2) = liftO2 (λ x y. relabel_reg (trim_reg (difference_reg x y))) (rr1_of_rr1_rel ℱ Rs s1) (rr1_of_rr1_rel ℱ Rs s2)"

| "rr2_of_rr2_rel ℱ Rs (R2GTT_Rel g w x) =
    (case w of PRoot ⇒
      (case x of ESingle ⇒ liftO1 (simplify_reg ∘ eps_free_reg ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel ℱ Rs g)
        | EParallel ⇒ liftO1 (simplify_reg ∘ eps_free_reg ∘ reflcl_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel ℱ Rs g)
        | EStrictParallel ⇒ liftO1 (simplify_reg ∘ eps_free_reg ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel ℱ Rs g))
      | PNonRoot ⇒
      (case x of ESingle ⇒ liftO1 (simplify_reg ∘ eps_free_reg ∘ nhole_ctxt_closure_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel ℱ Rs g)
        | EParallel ⇒ liftO1 (simplify_reg ∘ eps_free_reg ∘ nhole_mctxt_reflcl_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel ℱ Rs g)
        | EStrictParallel ⇒ liftO1 (simplify_reg ∘ eps_free_reg ∘ nhole_mctxt_closure_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel ℱ Rs g))
      | PAny ⇒
      (case x of ESingle ⇒ liftO1 (simplify_reg ∘ eps_free_reg ∘ ctxt_closure_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel ℱ Rs g)
        | EParallel ⇒ liftO1 (simplify_reg ∘ eps_free_reg ∘ parallel_closure_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel ℱ Rs g)
        | EStrictParallel ⇒ liftO1 (simplify_reg ∘ eps_free_reg ∘ mctxt_closure_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel ℱ Rs g)))"
| "rr2_of_rr2_rel ℱ Rs (R2Diag s) =
    liftO1 (λ x. fmap_funs_reg (λf. (Some f, Some f)) x) (rr1_of_rr1_rel ℱ Rs s)"
| "rr2_of_rr2_rel ℱ Rs (R2Prod s1 s2) =
    liftO2 (λ x y. simplify_reg (pair_automaton_reg x y)) (rr1_of_rr1_rel ℱ Rs s1) (rr1_of_rr1_rel ℱ Rs s2)"
| "rr2_of_rr2_rel ℱ Rs (R2Inv r) = liftO1 (fmap_funs_reg prod.swap) (rr2_of_rr2_rel ℱ Rs r)"
| "rr2_of_rr2_rel ℱ Rs (R2Union r1 r2) =
    liftO2 (λ x y. relabel_reg (reg_union x y)) (rr2_of_rr2_rel ℱ Rs r1) (rr2_of_rr2_rel ℱ Rs r2)"
| "rr2_of_rr2_rel ℱ Rs (R2Inter r1 r2) =
    liftO2 (λ x y. simplify_reg (reg_intersect x y)) (rr2_of_rr2_rel ℱ Rs r1) (rr2_of_rr2_rel ℱ Rs r2)"
| "rr2_of_rr2_rel ℱ Rs (R2Diff r1 r2) = liftO2 (λ x y. simplify_reg (difference_reg x y)) (rr2_of_rr2_rel ℱ Rs r1) (rr2_of_rr2_rel ℱ Rs r2)"
| "rr2_of_rr2_rel ℱ Rs (R2Comp r1 r2) = liftO2 (λ x y. simplify_reg (rr2_compositon ℱ x y))
     (rr2_of_rr2_rel ℱ Rs r1) (rr2_of_rr2_rel ℱ Rs r2)"


abbreviation lhss where
  "lhss R ≡ fst |`| R"

lemma rr12_of_rr12_rel_correct:
  fixes Rs :: "(('f :: linorder, 'v) Term.term × ('f, 'v) Term.term) fset list"
  assumes  "∀R ∈ set Rs. lv_trs (fset R) ∧ ffunas_trs R |⊆| ℱ"
  shows "∀ta1. rr1_of_rr1_rel ℱ Rs r1 = Some ta1 ⟶ RR1_spec ta1 (eval_rr1_rel (fset ℱ) (map fset Rs) r1)"
    "∀ta2. rr2_of_rr2_rel ℱ Rs r2 = Some ta2 ⟶ RR2_spec ta2 (eval_rr2_rel (fset ℱ) (map fset Rs) r2)"
proof (induct r1 and r2)
  note [simp] = bind_eq_Some_conv guard_simps
  let ?F = "fset ℱ" let ?Rs = "map fset Rs"
{
  case R1Terms
  then show ?case using term_automaton[of ℱ]
    by (simp add: 𝒯G_equivalent_def)
next
  case (R1NF r)
  consider (a) "∃ R. is_to_trs' Rs r = Some R" | (b) "is_to_trs' Rs r = None" by auto
  then show ?case
  proof (cases)
    case a
    from a obtain R where [simp]: "is_to_trs' Rs r = Some R" "is_to_fin_trs Rs r = R"
      by (auto simp: is_to_trs'_def)
    from is_to_trs'_props[OF assms this(1)] have inv: "ffunas_trs R |⊆| ℱ" "lv_trs (fset R)" .
    from inv have fl: "∀ l |∈| lhss R. linear_term l"
      by (auto simp: lv_trs_def fmember.rep_eq split!: prod.splits)
    {fix s t assume ass: "(s, t) ∈ grstep (fset R)"
      then obtain C l r σ where step: "(l, r) |∈| R" "term_of_gterm s = (C :: ('f, 'v) ctxt) ⟨l ⋅ σ⟩" "term_of_gterm t = C⟨r ⋅ σ⟩"
        unfolding grstep_def by (auto simp: fmember.rep_eq dest!: rstep_imp_C_s_r)
      from step ta_nf_lang_sound[of l "lhss R" C σ ℱ]
      have "s ∉ ℒ (nf_reg (lhss R) ℱ)" unfolding ℒ_def
        by (metis fimage_eqI fst_conv nf_reg_def reg.sel(1, 2) term_of_gterm_in_ta_lang_conv)}
    note mem = this
    have funas: "funas_trs (fset R) ⊆ ?F" using inv(1)
      by (simp add: ffunas_trs.rep_eq less_eq_fset.rep_eq subsetD)
    {fix s assume "s ∈ ℒ (nf_reg (lhss R) ℱ)"
      then have "s ∈ NF (Restr (grstep (fset R)) (𝒯G (fset ℱ))) ∩ 𝒯G (fset ℱ)"
        by (meson IntI NF_I 𝒯G_funas_gterm_conv gta_lang_nf_ta_funas inf.cobounded1 mem subset_iff)}
    moreover
    {fix s assume ass: "s ∈ NF (Restr (grstep (fset R)) (𝒯G (fset ℱ))) ∩ 𝒯G (fset ℱ)"
      then have *: "(term_of_gterm s, term_of_gterm t) ∉ rstep (fset R)" for t using funas
        by (auto simp: funas_trs_def grstep_def NF_iff_no_step 𝒯G_funas_gterm_conv fmember.rep_eq)
           (meson R1NF_reps funas rstep.cases)
      then have "s ∈ ℒ (nf_reg (lhss R) ℱ)" using fl ass
        using ta_nf_ℒ_complete[OF fl, of _ ℱ] gta_lang_nf_ta_funas[of _ "lhss R" ℱ]
        by (smt (verit, ccfv_SIG) IntE R1NF_reps 𝒯G_sound fimageE funas notin_fset surjective_pairing)}
    ultimately have "ℒ (nf_reg (lhss R) ℱ) = NF (Restr (grstep (fset R)) (𝒯G (fset ℱ))) ∩ 𝒯G (fset ℱ)"
      by blast
    then show ?thesis using fl(1)
      by (simp add: RR1_spec_def is_to_trs_conv)
  qed auto
next
  case (R1Inf r)
  consider (a) "∃ A. rr2_of_rr2_rel ℱ Rs r = Some A" | (b) " rr2_of_rr2_rel ℱ Rs r = None" by auto
  then show ?case
  proof cases
    case a
    have [simp]: "{u. (t, u) ∈ eval_rr2_rel ?F ?Rs r ∧ funas_gterm u ⊆ ?F} =
     {u. (t, u) ∈ eval_rr2_rel ?F ?Rs r}" for t
      using eval_rr12_rel_sig(2)[of ?F ?Rs r] by (auto simp: 𝒯G_equivalent_def)
    have [simp]: "infinite {u. (t, u) ∈ eval_rr2_rel ?F ?Rs r} ⟹ funas_gterm t ⊆ ?F" for t
      using eval_rr12_rel_sig(2)[of ?F ?Rs r] not_finite_existsD by (fastforce simp: 𝒯G_equivalent_def)
    from a obtain A where [simp]: "rr2_of_rr2_rel ℱ Rs r = Some A" by blast
    from R1Inf this have spec: "RR2_spec A (eval_rr2_rel ?F ?Rs r)" by auto
    then have spec_trim: "RR2_spec (trim_reg A) (eval_rr2_rel ?F ?Rs r)" by auto
    let ?B = "(Inf_reg (trim_reg A) (Q_infty (ta (trim_reg A)) ℱ))"
    have B: "RR2_spec ?B {(s, t) | s t. gpair s t ∈ ℒ ?B}"
      using subset_trans[OF Inf_automata_subseteq[of "trim_reg A" ℱ], of "ℒ A"] spec
      by (auto simp: RR2_spec_def ℒ_trim)
    have *: "ℒ (Inf_reg_impl (trim_reg A)) = ℒ ?B" using spec
      using eval_rr12_rel_sig(2)[of ?F ?Rs r]
      by (intro Inf_reg_impl_sound) (auto simp: ℒ_trim RR2_spec_def 𝒯G_equivalent_def)
    then have **: "RR2_spec (Inf_reg_impl (trim_reg A)) {(s, t) | s t. gpair s t ∈ ℒ ?B}" using B
      by (auto simp: RR2_spec_def)
    show ?thesis
      using spec eval_rr12_rel_sig(2)[of ?F ?Rs r]
      using ℒ_Inf_reg[OF spec_trim, of ℱ]
      by (auto simp: 𝒯G_equivalent_def * RR1_spec_def ℒ_trim ℒ_proj(1)[OF **]
                     Inf_branching_terms_def fImage_singleton)
         (metis (no_types, lifting) SigmaD1 in_mono mem_Collect_eq not_finite_existsD)
  qed auto
next
  case (R1Proj i r)
  then show ?case
  proof (cases i)
    case [simp]:0 show ?thesis using R1Proj
      using proj_automaton_gta_lang(1)[of "the (rr2_of_rr2_rel ℱ Rs r)" "eval_rr2_rel ?F ?Rs r"]
      by simp
  next
    case (Suc nat) then show ?thesis using R1Proj
      using proj_automaton_gta_lang(2)[of "the (rr2_of_rr2_rel ℱ Rs r)" "eval_rr2_rel ?F ?Rs r"]
      by simp
  qed
next
  case (R1Union s1 s2)
  then show ?case
    by (auto simp: RR1_spec_def ℒ_union)
next
  case (R1Inter s1 s2)
  from R1Inter show ?case
    by (auto simp: ℒ_intersect RR1_spec_def)
next
  case (R1Diff s1 s2)
  then show ?case
    by (auto intro: RR1_difference)
next
  case (R2GTT_Rel g w x)
  note ass = R2GTT_Rel
  consider (a) "∃ A. gtt_of_gtt_rel ℱ Rs g = Some A" | (b) "gtt_of_gtt_rel ℱ Rs g = None" by blast
  then show ?case
  proof cases
    case a then obtain A where [simp]: "gtt_of_gtt_rel ℱ Rs g = Some A" by blast
    from gtt_of_gtt_rel_correct[OF assms this]
    have spec [simp]: "eval_gtt_rel ?F ?Rs g = agtt_lang A" by auto
    let ?B = "GTT_to_RR2_root_reg A" note [simp] = GTT_to_RR2_root[of A]
    show ?thesis
    proof (cases w)
      case [simp]: PRoot show ?thesis
      proof (cases x)
        case EParallel
        then show ?thesis using reflcl_automaton[of ?B "agtt_lang A" ℱ]
          by auto
      qed (auto simp: GTT_to_RR2_root)
    next
      case PNonRoot
      then show ?thesis
        using nhole_ctxt_closure_automaton[of ?B "agtt_lang A" ℱ]
        using nhole_mctxt_reflcl_automaton[of ?B "agtt_lang A" ℱ]
        using nhole_mctxt_closure_automaton[of ?B "agtt_lang A" ℱ]
        by (cases x) auto
    next
      case PAny
      then show ?thesis
        using ctxt_closure_automaton[of ?B "agtt_lang A" ℱ]
        using parallel_closure_automaton[of ?B "agtt_lang A" ℱ]
        using mctxt_closure_automaton[of ?B "agtt_lang A" ℱ]
        by (cases x) auto
    qed
  qed (cases w; cases x, auto)
next
  case (R2Diag s)
  then show ?case
    by (auto simp: RR2_spec_def RR1_spec_def fmap_funs_ℒ Id_on_iff
                   fmap_funs_gta_lang map_funs_term_some_gpair)
next
  case (R2Prod s1 s2)
  then show ?case using pair_automaton[of "the (rr1_of_rr1_rel ℱ Rs s1)" _ "the (rr1_of_rr1_rel ℱ Rs s2)"]
    by auto
next
  case (R2Inv r)
  show ?case using R2Inv by (auto simp: swap_RR2_spec)
next
  case (R2Union r1 r2)
  then show ?case using union_automaton
    by (auto simp: RR2_spec_def ℒ_union)
next
  case (R2Inter r1 r2)
  then show ?case
    by (auto simp: ℒ_intersect RR2_spec_def)
next
  case (R2Diff r1 r2)
  then show ?case by (auto intro: RR2_difference)
next
  case (R2Comp r1 r2)
  then show ?case using eval_rr12_rel_sig
    by (auto intro!: rr2_compositon) blast+
}
qed


subsection ‹Misc›

lemma eval_formula_arity_cong:
  assumes "⋀i. i < formula_arity f ⟹ α' i = α i"
  shows "eval_formula ℱ Rs α' f = eval_formula ℱ Rs α f"
proof -
  have [simp]: "j < length fs ⟹ i < formula_arity (fs ! j) ⟹ i < max_list (map formula_arity fs)" for i j fs
    by (simp add: less_le_trans max_list)
  show ?thesis using assms
  proof (induct f arbitrary: α α')
    case (FAnd fs)
    show ?case using FAnd(1)[OF nth_mem, of _ α' α] FAnd(2) by (auto simp: all_set_conv_all_nth)
  next
    case (FOr fs)
    show ?case using FOr(1)[OF nth_mem, of _ α' α] FOr(2) by (auto simp: ex_set_conv_ex_nth)
  next
    case (FNot f)
    show ?case using FNot(1)[of α' α] FNot(2) by simp
  next
    case (FExists f)
    show ?case using FExists(1)[of "α'⟨0 : z⟩" "α⟨0 : z⟩" for z] FExists(2) by (auto simp: shift_def)
  next
    case (FForall f)
    show ?case using FForall(1)[of "α'⟨0 : z⟩" "α⟨0 : z⟩" for z] FForall(2) by (auto simp: shift_def)
  qed simp_all
qed


subsection ‹Connect semantics to FOL-Fitting›

primrec form_of_formula :: "'trs formula ⇒ (unit, 'trs rr1_rel + 'trs rr2_rel) form" where
  "form_of_formula (FRR1 r1 x) = Pred (Inl r1) [Var x]"
| "form_of_formula (FRR2 r2 x y) = Pred (Inr r2) [Var x, Var y]"
| "form_of_formula (FAnd fs) = foldr And (map form_of_formula fs) TT"
| "form_of_formula (FOr fs) = foldr Or (map form_of_formula fs) FF"
| "form_of_formula (FNot f) = Neg (form_of_formula f)"
| "form_of_formula (FExists f) = Exists (And (Pred (Inl R1Terms) [Var 0]) (form_of_formula f))"
| "form_of_formula (FForall f) = Forall (Impl (Pred (Inl R1Terms) [Var 0]) (form_of_formula f))"


fun for_eval_rel :: "('f × nat) set ⇒ ('f, 'v) trs list ⇒ ftrs rr1_rel + ftrs rr2_rel ⇒ 'f gterm list ⇒ bool" where
  "for_eval_rel ℱ Rs (Inl r1) [t] ⟷ t ∈ eval_rr1_rel ℱ Rs r1"
| "for_eval_rel ℱ Rs (Inr r2) [t, u] ⟷ (t, u) ∈ eval_rr2_rel ℱ Rs r2"

lemma eval_formula_conv:
  "eval_formula ℱ Rs α f = eval α undefined (for_eval_rel ℱ Rs) (form_of_formula f)"
proof (induct f arbitrary: α)
  case (FAnd fs) then show ?case
    unfolding eval_formula.simps by (induct fs) auto
next
  case (FOr fs) then show ?case
    unfolding eval_formula.simps by (induct fs) auto
qed auto


subsection ‹RRn relations and formulas›

lemma shift_rangeI [intro!]:
  "range α ⊆ T ⟹ x ∈ T ⟹ range (shift α i x) ⊆ T"
  by (auto simp: shift_def)

definition formula_relevant where
  "formula_relevant ℱ Rs vs fm ⟷
     (∀α α'. range α ⊆ 𝒯G ℱ ⟶ range α' ⊆ 𝒯G ℱ ⟶ map α vs = map α' vs ⟶ eval_formula ℱ Rs α fm ⟶ eval_formula ℱ Rs α' fm)"

lemma formula_relevant_mono:
  "set vs ⊆ set ws ⟹ formula_relevant ℱ Rs vs fm ⟹ formula_relevant ℱ Rs ws fm"
  unfolding formula_relevant_def
  by (meson map_eq_conv subset_code(1))

lemma formula_relevantD:
  "formula_relevant ℱ Rs vs fm ⟹
   range α ⊆ 𝒯G ℱ ⟹ range α' ⊆ 𝒯G ℱ ⟹ map α vs = map α' vs ⟹
   eval_formula ℱ Rs α fm ⟹ eval_formula ℱ Rs α' fm"
  unfolding formula_relevant_def
  by blast

lemma trivial_formula_relevant:
  assumes "⋀α. range α ⊆ 𝒯G ℱ ⟹ ¬ eval_formula ℱ Rs α fm"
  shows "formula_relevant ℱ Rs vs fm"
  using assms unfolding formula_relevant_def
  by auto

lemma formula_relevant_0_FExists:
  assumes "formula_relevant ℱ Rs [0] fm"
  shows "formula_relevant ℱ Rs [] (FExists fm)"
  unfolding formula_relevant_def
proof (intro allI, intro impI)
  fix α α' assume ass: "range α ⊆ 𝒯G ℱ" "range (α' :: fvar ⇒ 'a gterm) ⊆ 𝒯G ℱ"
    "eval_formula ℱ Rs α (FExists fm)"
  from ass(3) obtain z where "z ∈ 𝒯G ℱ" "eval_formula ℱ Rs (α⟨0 : z⟩) fm"
    by auto
  then show "eval_formula ℱ Rs α' (FExists fm)"
    using ass(1, 2) formula_relevantD[OF assms, of "α⟨0:z⟩" "α'⟨0:z⟩"]
    by (auto simp: shift_rangeI intro!: exI[of _ z])
qed

definition formula_spec where
  "formula_spec ℱ Rs vs A fm ⟷ sorted vs ∧ distinct vs ∧
     formula_relevant ℱ Rs vs fm ∧
     RRn_spec (length vs) A {map α vs |α. range α ⊆ 𝒯G ℱ ∧ eval_formula ℱ Rs α fm}"

lemma formula_spec_RRn_spec:
  "formula_spec ℱ Rs vs A fm ⟹ RRn_spec (length vs) A {map α vs |α. range α ⊆ 𝒯G ℱ ∧ eval_formula ℱ Rs α fm}"
  by (simp add: formula_spec_def)

lemma formula_spec_nt_empty_form_sat:
  "¬ reg_empty A ⟹ formula_spec ℱ Rs vs A fm ⟹ ∃ α. range α ⊆ 𝒯G ℱ ∧ eval_formula ℱ Rs α fm"
  unfolding formula_spec_def
  by (auto simp: RRn_spec_def ℒ_def)

lemma formula_spec_empty:
  "reg_empty A ⟹ formula_spec ℱ Rs vs A fm ⟹ range α ⊆ 𝒯G ℱ ⟹ eval_formula ℱ Rs α fm ⟷ False"
  unfolding formula_spec_def
  by (auto simp: RRn_spec_def ℒ_def)

text ‹In each inference step, we obtain a triple consisting of a formula @{term "fm"}, a list of
  relevant variables @{term "vs"} (typically a sublist of @{term "[0..<formula_arity fm]"}), and
  an RRn automaton @{term "A"}, such that the property @{term "formula_spec ℱ Rs vs A fm"} holds.›

lemma false_formula_spec:
  "sorted vs ⟹ distinct vs ⟹ formula_spec ℱ Rs vs empty_reg FFalse"
  by (auto simp: formula_spec_def false_RRn_spec FFalse_def formula_relevant_def)

lemma true_formula_spec:
  assumes "vs ≠ [] ∨ 𝒯G (fset ℱ) ≠ {}" "sorted vs" "distinct vs"
  shows "formula_spec (fset ℱ) Rs vs (true_RRn ℱ (length vs)) FTrue"
proof -
  have "{ts. length ts = length vs ∧ set ts ⊆ 𝒯G (fset ℱ)} = {map α vs |α. range α ⊆ 𝒯G (fset ℱ)}"
  proof (intro equalityI subsetI CollectI, goal_cases LR RL)
    case (LR ts)
    moreover obtain t0 where "funas_gterm t0 ⊆ fset ℱ" using LR assms(1) unfolding 𝒯G_equivalent_def
      by (cases vs) fastforce+
    ultimately show ?case using `distinct vs`
      apply (intro exI[of _ "λt. if t ∈ set vs then ts ! inv_into {0..<length vs} ((!) vs) t else t0"])
      apply (auto intro!: nth_equalityI dest!: inj_on_nth[of vs "{0..<length vs}"] simp: in_set_conv_nth 𝒯G_equivalent_def)
      by (metis inv_to_set mem_Collect_eq subsetD) 
  qed fastforce
  then show ?thesis using assms true_RRn_spec[of "length vs" ℱ]
    by (auto simp: formula_spec_def FTrue_def formula_relevant_def 𝒯G_equivalent_def)
qed

lemma relabel_formula_spec:
  "formula_spec ℱ Rs vs A fm ⟹ formula_spec ℱ Rs vs (relabel_reg A) fm"
  by (simp add: formula_spec_def)

lemma trim_formula_spec:
  "formula_spec ℱ Rs vs A fm ⟹ formula_spec ℱ Rs vs (trim_reg A) fm"
  by (simp add: formula_spec_def)

definition fit_permute :: "nat list ⇒ nat list ⇒ nat list ⇒ nat list" where
  "fit_permute vs vs' vs'' = map (λv. if v ∈ set vs then the (mem_idx v vs) else length vs + the (mem_idx v vs'')) vs'"

definition fit_rrn :: "('f × nat) fset ⇒ nat list ⇒ nat list ⇒ (nat, 'f option list) reg ⇒ (_, 'f option list) reg" where
  "fit_rrn ℱ vs vs' A = (let vs'' = subtract_list_sorted vs' vs in
    fmap_funs_reg (λfs. map ((!) fs) (fit_permute vs vs' vs''))
      (fmap_funs_reg (pad_with_Nones (length vs) (length vs'')) (pair_automaton_reg A (true_RRn ℱ (length vs'')))))"

lemma the_mem_idx_simp [simp]:
  "distinct xs ⟹ i < length xs ⟹ the (mem_idx (xs ! i) xs) = i"
  using mem_idx_sound[THEN iffD1, OF nth_mem, of i xs] mem_idx_sound_output[of "xs ! i" xs] distinct_conv_nth
  by fastforce

lemma fit_rrn:
  assumes spec: "formula_spec (fset ℱ) Rs vs A fm" and vs: "sorted vs'" "distinct vs'" "set vs ⊆ set vs'"
  shows "formula_spec (fset ℱ) Rs vs' (fit_rrn ℱ vs vs' A) fm"
  using spec unfolding formula_spec_def formula_relevant_def
  apply (elim conjE)
proof (intro conjI vs(1,2) allI, goal_cases rel spec)
  case (rel α α') show ?case using vs(3)
    by (fastforce intro!: rel(3)[rule_format, of α α'])
next
  case spec
  define vs'' where "vs'' = subtract_list_sorted vs' vs"
  have evalI: "range α ⊆ 𝒯G (fset ℱ) ⟹ range α' ⊆ 𝒯G (fset ℱ) ⟹ map α vs = map α' vs
   ⟹ eval_formula (fset ℱ) Rs α fm ⟹ eval_formula (fset ℱ) Rs α' fm" for α α'
    using spec(3) by blast
  have [simp]: "set vs' = set vs ∪ set vs''" "set vs'' ∩ set vs = {}" "set vs ∩ set vs'' = {}" and d: "distinct vs''"
    using vs spec(1,2) by (auto simp: vs''_def)
  then have [dest]: "v ∈ set vs'' ⟹ v ∈ set vs ⟹ False" for v by blast
  note * = permute_automaton[OF append_automaton[OF spec(4) true_RRn_spec, of "length vs''"]]
  have [simp]: "distinct vs ⟹ i ∈ set vs ⟹ vs ! the (mem_idx i vs) = (i :: nat)" for vs i
    by (simp add: mem_idx_sound mem_idx_sound_output)
  have [dest]: "distinct vs ⟹ i ∈ set vs ⟹ ¬ the (mem_idx i vs) < length vs ⟹ False" for i
    by (meson mem_idx_sound2 mem_idx_sound_output option.exhaust_sel)
  show ?case unfolding fit_rrn_def Let_def vs''_def[symmetric] 𝒯G_equivalent_def
    apply (rule subst[where P = "λl. RRn_spec l _ _", OF _ subst[where P = "λta. RRn_spec _ _ ta", OF _ *]])
    subgoal by (simp add: fit_permute_def)
    subgoal
      apply (intro equalityI subsetI CollectI imageI; elim imageE CollectE exE conjE; unfold 𝒯G_equivalent_def)
      subgoal for x fs ts us α
        using spec(1, 2) d
        apply (intro exI[of _ "λv. if v ∈ set vs'' then us ! the (mem_idx v vs'') else α v"])
        apply (auto simp: fit_permute_def nth_append 𝒯G_equivalent_def
                    intro!: nth_equalityI evalI[of α "λv. if v ∈ set vs'' then us ! the (mem_idx v vs'') else α v"])
        apply (metis distinct_Ex1 in_mono mem_Collect_eq nth_mem the_mem_idx_simp)
        apply (metis distinct_Ex1 in_mono mem_Collect_eq nth_mem the_mem_idx_simp)
        apply blast
        by (meson ‹⋀va. ⟦va ∈ set vs''; va ∈ set vs⟧ ⟹ False› nth_mem)
      subgoal premises p for xs α
        apply (intro rev_image_eqI[of "map α (vs @ vs'')"])
        subgoal using p by (force intro!: exI[of _ "map α vs", OF exI[of _ "map α vs''"]])
        subgoal using p(1)
          by (force intro!: nth_equalityI simp: fit_permute_def comp_def nth_append dest: iffD1[OF mem_idx_sound] mem_idx_sound_output)
        done
      done
    subgoal using vs spec(1,2) unfolding fit_permute_def
      apply (intro equalityI subsetI)
      subgoal by (auto 0 3 dest: iffD1[OF mem_idx_sound] mem_idx_sound_output)
      subgoal for x
        apply (simp add: Compl_eq[symmetric] Diff_eq[symmetric] Un_Diff Diff_triv Int_absorb1)
        apply (simp add: nth_image[symmetric, of "length xs" xs for xs, simplified] image_iff comp_def)
        using image_cong[OF refl arg_cong[OF the_mem_idx_simp]] ‹distinct vs''›
        by (smt (z3) add_diff_inverse_nat add_less_cancel_left atLeast0LessThan lessThan_iff the_mem_idx_simp)
      done
  done
qed

definition fit_rrns :: "('f × nat) fset ⇒ (ftrs formula × nat list × (nat, 'f option list) reg) list ⇒
  nat list × ((nat, 'f option list) reg) list" where
  "fit_rrns ℱ rrns = (let vs' = fold union_list_sorted (map (fst ∘ snd) rrns) [] in
    (vs', map (λ(fm, vs, ta). relabel_reg (trim_reg (fit_rrn ℱ vs vs' ta))) rrns))"

lemma sorted_union_list_sortedI [simp]:
  "sorted xs ⟹ sorted ys ⟹ sorted (union_list_sorted xs ys)"
  by (induct xs ys rule: union_list_sorted.induct) auto

lemma distinct_union_list_sortedI [simp]:
  "sorted xs ⟹ sorted ys ⟹ distinct xs ⟹ distinct ys ⟹ distinct (union_list_sorted xs ys)"
  by (induct xs ys rule: union_list_sorted.induct) auto

lemma fit_rrns:
  assumes infs: "⋀fvA. fvA ∈ set rrns ⟹ formula_spec (fset ℱ) Rs (fst (snd fvA)) (snd (snd fvA)) (fst fvA)"
  assumes "(vs', tas') = fit_rrns ℱ rrns"
  shows "length tas' = length rrns" "⋀i. i < length rrns ⟹ formula_spec (fset ℱ) Rs vs' (tas' ! i) (fst (rrns ! i))"
    "distinct vs'" "sorted vs'"
proof (goal_cases)
  have vs': "vs' = fold union_list_sorted (map (fst ∘ snd) rrns) []" using assms(2) by (simp add: fit_rrns_def Let_def)
  have *: "sorted vs'" "distinct vs'" "⋀fvA. fvA ∈ set rrns ⟹ set (fst (snd fvA)) ⊆ set vs'"
    using infs[unfolded formula_spec_def, THEN conjunct2, THEN conjunct1]
      infs[unfolded formula_spec_def, THEN conjunct1]
    unfolding vs' by (induct rrns rule: rev_induct) auto
{
  case 1 then show ?case using assms(2) by (simp add: fit_rrns_def Let_def)
next
  case (2 i)
  have tas': "tas' ! i = relabel_reg (trim_reg (fit_rrn ℱ (fst (snd (rrns ! i))) vs' (snd (snd (rrns ! i)))))"
    using 2 assms(2) by (simp add: fit_rrns_def Let_def split: prod.splits)
  from *(1,2) *(3)[OF nth_mem] show ?case using 2 unfolding tas'
    by (auto intro!: relabel_formula_spec trim_formula_spec fit_rrn 2 assms(1,2))
next
  case 3 show ?case by (rule *)
next
  case 4 show ?case by (rule *)
}
qed


subsection ‹Building blocks›

definition for_rrn where
  "for_rrn tas = fold (λA B. relabel_reg (reg_union A B)) tas (Reg {||} (TA {||} {||}))"

lemma for_rrn:
  assumes "length tas = length fs" "⋀i. i < length fs ⟹ formula_spec ℱ Rs vs (tas ! i) (fs ! i)"
    and vs: "sorted vs" "distinct vs"
  shows "formula_spec ℱ Rs vs (for_rrn tas) (FOr fs)"
  using assms(1,2) unfolding for_rrn_def
proof (induct fs arbitrary: tas rule: rev_induct)
  case Nil then show ?case using vs false_formula_spec[of vs ℱ Rs] by (auto simp: FFalse_def)
next
  case (snoc fm fs)
  have *: "Bex (set [x]) P = P x" for P x by auto
  have [intro!]: "formula_spec ℱ Rs vs (reg_union A B) (FOr (fs @ [fm]))" if
    "formula_spec ℱ Rs vs A fm" "formula_spec ℱ Rs vs B (FOr fs)" for A B using that
    unfolding formula_spec_def
    apply (intro conjI, blast, blast)
    subgoal unfolding formula_relevant_def eval_formula.simps set_append bex_Un * by blast
    apply (elim conjE)
    subgoal premises p by (rule subst[of _ _ "RRn_spec _ _", OF _ union_automaton[OF p(6,8)]]) auto
    done
  show ?case using snoc(1)[of "take (length fs) tas"] snoc(2) snoc(3)[simplified, OF less_SucI] snoc(3)[of "length fs"] vs
    by (cases tas rule: rev_exhaust) (auto simp: min_def nth_append intro!: relabel_formula_spec)
qed

fun fand_rrn where
  "fand_rrn ℱ n [] = true_RRn ℱ n"
| "fand_rrn ℱ n (A # tas) = fold (λA B. simplify_reg (reg_intersect A B)) tas A"

lemma fand_rrn:
  assumes "𝒯G (fset ℱ) ≠ {}" "length tas = length fs" "⋀i. i < length fs ⟹ formula_spec (fset ℱ) Rs vs (tas ! i) (fs ! i)"
    and vs: "sorted vs" "distinct vs"
  shows "formula_spec (fset ℱ) Rs vs (fand_rrn ℱ (length vs) tas) (FAnd fs)"
proof (cases fs)
  case Nil
  have "tas = []" using assms(2) by (auto simp: Nil)
  then show ?thesis using true_formula_spec[OF _ vs, of ℱ Rs] assms(1) Nil
    by (simp add: FTrue_def)
next
  case (Cons fm fs)
  obtain ta tas' where tas: "tas = ta # tas'" using assms(2) Cons by (cases tas) auto
  show ?thesis using assms(2) assms(3)[of "Suc _"] unfolding tas Cons
    unfolding list.size add_Suc_right add_0_right nat.inject Suc_less_eq nth_Cons_Suc fand_rrn.simps
  proof (induct fs arbitrary: tas' rule: rev_induct)
    case Nil
    have "formula_relevant (fset ℱ) Rs vs (FAnd [fm])" using assms(3)[of 0]
      apply (simp add: tas Cons formula_spec_def)
      unfolding formula_relevant_def eval_formula.simps in_set_simps by blast
    then show ?case using assms(3)[of 0, unfolded tas Cons, simplified] Nil by (simp add: formula_spec_def)
  next
    case (snoc fm' fs)
    have *: "Ball (insert x X) P ⟷ P x ∧ Ball X P" for P x X by auto
    have [intro!]: "formula_spec (fset ℱ) Rs vs (reg_intersect A B) (FAnd (fm # fs @ [fm']))" if
      "formula_spec (fset ℱ) Rs vs A fm'" "formula_spec (fset ℱ) Rs vs B (FAnd (fm # fs))" for A B using that
      unfolding formula_spec_def
      apply (intro conjI, blast, blast)
      subgoal unfolding formula_relevant_def eval_formula.simps set_append set_simps ball_simps ball_Un in_set_simps *
        by blast
      apply (elim conjE)
      subgoal premises p
        by (rule subst[of _ _ "RRn_spec _ _", OF _ intersect_automaton[OF p(6,8)]])
          (auto dest:  p(5)[unfolded formula_relevant_def, rule_format])
      done
    show ?case using snoc(1)[of "take (length fs) tas'"] snoc(2) snoc(3)[simplified, OF less_SucI] snoc(3)[of "length fs"] vs
      by (cases tas' rule: rev_exhaust) (auto simp: min_def nth_append simplify_reg_def intro!: relabel_formula_spec trim_formula_spec)
  qed
qed

subsubsection ‹IExists inference rule›

lemma lift_fun_gpairD:
  "map_gterm lift_fun s = gpair t u ⟹ t = s"
  "map_gterm lift_fun s = gpair t u ⟹ u = s"
  by (metis gfst_gpair gsnd_gpair map_funs_term_some_gpair)+

definition upd_bruijn :: "nat list ⇒ nat list" where
  "upd_bruijn vs = tl (map (λ x. x - 1) vs)"

lemma upd_bruijn_length[simp]:
  "length (upd_bruijn vs) = length vs - 1"
  by (induct vs) (auto simp: upd_bruijn_def)

lemma pres_sorted_dec:
  "sorted xs ⟹ sorted (map (λx. x - Suc 0) xs)"
  by (induct xs) auto

lemma upd_bruijn_pres_sorted:
  "sorted xs ⟹ sorted (upd_bruijn xs)"
  unfolding upd_bruijn_def
  by (intro sorted_tl) (auto simp: pres_sorted_dec)

lemma pres_distinct_not_0_list_dec:
  "distinct xs ⟹ 0 ∉ set xs ⟹ distinct (map (λx. x - Suc 0) xs)"
  by (induct xs) (auto, metis Suc_pred neq0_conv)

lemma upd_bruijn_pres_distinct:
  assumes "sorted xs" "distinct xs"
  shows "distinct (upd_bruijn xs)"
proof -
  have "sorted (ys :: nat list) ⟹ distinct ys ⟹ 0 ∉ set (tl ys)" for ys
    by (induct ys) auto
  from this[OF assms] show ?thesis using assms(2)
    using pres_distinct_not_0_list_dec[OF distinct_tl, OF assms(2)]
    unfolding upd_bruijn_def
    by (simp add: map_tl)
qed

lemma upd_bruijn_relevant_inv:
  assumes "sorted vs" "distinct vs" "0 ∈ set vs"
    and "⋀ x. x ∈ set (upd_bruijn vs) ⟹ α x = α' x"
  shows "⋀ x. x ∈ set vs ⟹ (shift α 0 z) x = (shift α' 0 z) x"
  using assms unfolding upd_bruijn_def
  by (induct vs) (auto simp add: FOL_Fitting.shift_def)

lemma ExistsI_upd_brujin_0:
  assumes "sorted vs" "distinct vs" "0 ∈ set vs" "formula_relevant ℱ Rs vs fm"
  shows "formula_relevant ℱ Rs (upd_bruijn vs) (FExists fm)"
  unfolding formula_relevant_def
proof (intro allI, intro impI)
  fix α α' assume ass: "range α ⊆ 𝒯G ℱ" "range (α' :: fvar ⇒ 'a gterm) ⊆ 𝒯G ℱ"
    "map α (upd_bruijn vs) = map α' (upd_bruijn vs)" "eval_formula ℱ Rs α (FExists fm)"
  from ass(4) obtain z where "z ∈ 𝒯G ℱ" "eval_formula ℱ Rs (α⟨0 : z⟩) fm"
    by auto
  then show "eval_formula ℱ Rs α' (FExists fm)"
    using ass(1 - 3) formula_relevantD[OF assms(4), of "α⟨0:z⟩" "α'⟨0:z⟩"]
    using upd_bruijn_relevant_inv[OF assms(1 - 3), of "α" "α'"]
    by (auto simp: shift_rangeI intro!: exI[of _ z])
qed

declare subsetI[rule del]
lemma ExistsI_upd_brujin_no_0:
  assumes "0 ∉ set vs" and "formula_relevant ℱ Rs vs fm"
  shows "formula_relevant ℱ Rs (map (λx. x - Suc 0) vs) (FExists fm)"
  unfolding formula_relevant_def
proof ((intro allI)+ , (intro impI)+, unfold eval_formula.simps)
  fix α α' assume st: "range α ⊆ 𝒯G ℱ" "range α' ⊆ 𝒯G ℱ"
  "map α (map (λx. x - Suc 0) vs) = map α' (map (λx. x - Suc 0) vs)"
  "∃ z ∈ 𝒯G ℱ. eval_formula ℱ Rs (shift α 0 z) fm"
  then obtain z where w: "z ∈ 𝒯G ℱ" "eval_formula ℱ Rs (shift α 0 z) fm" by auto
  from this(1) have "eval_formula ℱ Rs (shift α' 0 z) fm"
    using st(1 - 3) assms(1) FOL_Fitting.shift_def
    apply (intro formula_relevantD[OF assms(2) _ _ _ w(2), of "shift α' 0 z"])
    by auto (simp add: FOL_Fitting.shift_def)
  then show "∃ z ∈ 𝒯G ℱ. eval_formula ℱ Rs (shift α' 0 z) fm" using w(1)
    by blast
qed

definition shift_right where
  "shift_right α ≡ λ i. α (i + 1)"

lemma shift_right_nt_0:
  "i ≠ 0 ⟹ α i = shift_right α (i - Suc 0)"
  unfolding shift_right_def
  by auto

lemma shift_shift_right_id [simp]:
  "shift (shift_right α) 0 (α 0) = α"
  by (auto simp: shift_def shift_right_def)

lemma shift_right_rangeI [intro]:
  "range α ⊆ T ⟹ range (shift_right α) ⊆ T"
  by (auto simp: shift_right_def intro: subsetI)

lemma eval_formula_shift_right_eval:
  "eval_formula ℱ Rs α fm ⟹ eval_formula ℱ Rs (shift (shift_right α) 0 (α 0)) fm"
  "eval_formula ℱ Rs (shift (shift_right α) 0 (α 0)) fm ⟹ eval_formula ℱ Rs α fm"
  by (auto)
declare subsetI[intro!]

lemma nt_rel_0_trivial_shift:
  assumes "0 ∉ set vs"
  shows "{map α vs |α. range α ⊆ 𝒯G ℱ ∧ eval_formula ℱ Rs α fm} =
         {map (λx. α (x - Suc 0)) vs |α. range α ⊆ 𝒯G ℱ ∧ (∃z ∈ 𝒯G ℱ. eval_formula ℱ Rs (α⟨0:z⟩) fm)}"
    (is "?Ls = ?Rs")
proof
  {fix α assume ass: "range α ⊆ 𝒯G ℱ" "eval_formula ℱ Rs α fm" 
    then have "map α vs = map (λx. (shift_right α) (x - Suc 0)) vs"
      "range (shift_right α) ⊆ 𝒯G ℱ" "α 0 ∈𝒯G ℱ" "eval_formula ℱ Rs (shift (shift_right α) 0 (α 0)) fm"
      using shift_right_rangeI[OF ass(1)] assms
      by (auto intro: eval_formula_shift_right_eval(1), metis shift_right_nt_0)}
  then show "?Ls ⊆ ?Rs"
    by blast
next
  show "?Rs ⊆ ?Ls"
    by auto (metis FOL_Fitting.shift_def One_nat_def assms not_less0 shift_rangeI)
qed

lemma relevant_vars_upd_bruijn_tl:
  assumes "sorted vs" "distinct vs"
  shows "map (shift_right α) (upd_bruijn vs) = tl (map α vs)" using assms
proof (induct vs)
  case (Cons a vs) then show ?case
    using le_antisym
    by (auto simp: upd_bruijn_def shift_right_def)
       (metis One_nat_def Suc_eq_plus1 le_0_eq shift_right_def shift_right_nt_0)
qed (auto simp: upd_bruijn_def)

lemma drop_upd_bruijn_set:
  assumes "sorted vs" "distinct vs"
  shows "drop 1 ` {map α vs |α. range α ⊆ 𝒯G ℱ ∧ eval_formula ℱ Rs α fm} =
         {map α (upd_bruijn vs) |α. range α ⊆ 𝒯G ℱ ∧ (∃z∈𝒯G ℱ. eval_formula ℱ Rs (α⟨0:z⟩) fm)}"
    (is "?Ls = ?Rs")
proof
  {fix α assume ass: "range α ⊆ 𝒯G ℱ" "eval_formula ℱ Rs α fm" 
    then have "drop 1 (map α vs) = map (shift_right α) (upd_bruijn vs)"
      "range (shift_right α) ⊆ 𝒯G ℱ" "α 0 ∈𝒯G ℱ" "eval_formula ℱ Rs (shift (shift_right α) 0 (α 0)) fm"
      using shift_right_rangeI[OF ass(1)]
      by (auto simp: tl_drop_conv relevant_vars_upd_bruijn_tl[OF assms(1, 2)])}
  then show "?Ls ⊆ ?Rs"
    by blast
next
  have [dest]: "0 ∈ set (tl vs) ⟹ False" using assms(1, 2)
    by (cases vs) auto
  {fix α z assume ass: "range α ⊆ 𝒯G ℱ" "z ∈ 𝒯G ℱ" "eval_formula ℱ Rs (α⟨0:z⟩) fm"
    then have "map α (upd_bruijn vs) = tl (map (α⟨0:z⟩) vs)"
      "range (α⟨0:z⟩) ⊆ 𝒯G ℱ" "eval_formula ℱ Rs (α⟨0:z⟩) fm"
      using shift_rangeI[OF ass(1)]
      by (auto simp: upd_bruijn_def shift_def simp flip: map_tl)}
  then show "?Rs ⊆ ?Ls"
    by (auto simp: tl_drop_conv image_def) blast
qed


lemma closed_sat_form_env_dom:
  assumes "formula_relevant ℱ Rs [] (FExists fm)" "range α ⊆ 𝒯G ℱ" "eval_formula ℱ Rs α fm"
  shows "{[α 0] |α. range α ⊆ 𝒯G ℱ ∧ (∃ z ∈ 𝒯G ℱ. eval_formula ℱ Rs (α⟨0:z⟩) fm)} = {[t] | t. t ∈ 𝒯G ℱ}"
  using formula_relevantD[OF assms(1)] assms(2-)
  apply auto
  apply blast
  by (smt rangeI shift_eq shift_rangeI shift_right_rangeI shift_shift_right_id subsetD)

(* MOVE *)
lemma find_append:
  "find P (xs @ ys) = (if find P xs ≠ None then find P xs else find P ys)"
  by (induct xs arbitrary: ys) (auto split!: if_splits)

subsection ‹Checking inferences›

derive linorder ext_step pos_step gtt_rel rr1_rel rr2_rel ftrs
derive compare ext_step pos_step gtt_rel rr1_rel rr2_rel ftrs

fun check_inference :: "(('f × nat) fset ⇒ ('f, 'v) fin_trs list ⇒ ftrs rr1_rel ⇒ (nat, 'f) reg option)
  ⇒ (('f × nat) fset ⇒ ('f, 'v) fin_trs list ⇒ ftrs rr2_rel ⇒ (nat, 'f option × 'f option) reg option)
  ⇒ ('f × nat) fset ⇒ ('f :: compare, 'v) fin_trs list
  ⇒ (ftrs formula × nat list × (nat, 'f option list) reg) list
  ⇒ (nat × ftrs inference × ftrs formula × info list)
  ⇒ (ftrs formula × nat list × (nat, 'f option list) reg) option" where
  "check_inference rr1c rr2c ℱ Rs infs (l, step, fm, is) = do {
    guard (l = length infs);
    case step of
      IRR1 s x ⇒ do {
        guard (fm = FRR1 s x);
        liftO1 (λta. (FRR1 s x, [x], fmap_funs_reg (λf. [Some f]) ta)) (rr1c ℱ Rs s)
    }
    | IRR2 r x y ⇒ do {
        guard (fm = FRR2 r x y);
        case compare x y of
          Lt ⇒ liftO1 (λta. (FRR2 r x y, [x, y], fmap_funs_reg (λ(f, g). [f, g]) ta)) (rr2c ℱ Rs r)
        | Eq ⇒ liftO1 (λta. (FRR2 r x y, [x], fmap_funs_reg (λf. [Some f]) ta))
          (liftO1 (simplify_reg ∘ proj_1_reg)
          (liftO2 (λ t1 t2. simplify_reg (reg_intersect t1 t2)) (rr2c ℱ Rs r) (rr2c ℱ Rs (R2Diag R1Terms))))
        | Gt ⇒ liftO1 (λta. (FRR2 r x y, [y, x], fmap_funs_reg (λ(f, g). [g, f]) ta)) (rr2c ℱ Rs r)
    }
    | IAnd ls ⇒ do {
        guard (∀l' ∈ set ls. l' < l);
        guard (fm = FAnd (map (λl'. fst (infs ! l')) ls));
        let (vs', tas') = fit_rrns ℱ (map ((!) infs) ls) in
        Some (fm, vs', fand_rrn ℱ (length vs') tas')
    }
    | IOr ls ⇒ do {
        guard (∀l' ∈ set ls. l' < l);
        guard (fm = FOr (map (λl'. fst (infs ! l')) ls));
        let (vs', tas') = fit_rrns ℱ (map ((!) infs) ls) in
        Some (fm, vs', for_rrn tas')
    }
    | INot l' ⇒ do {
        guard (l' < l);
        guard (fm = FNot (fst (infs ! l')));
        let (vs', tas') = snd (infs ! l');
        Some (fm, vs', simplify_reg (difference_reg (true_RRn ℱ (length vs')) tas'))
    }
    | IExists l' ⇒ do {
        guard (l' < l);
        guard (fm = FExists (fst (infs ! l')));
        let (vs', tas') = snd (infs ! l');
        if length vs' = 0 then Some (fm, [], tas') else
          if reg_empty tas' then Some (fm, [], empty_reg)
          else if 0 ∉ set vs' then Some (fm, map (λ x. x - 1) vs', tas')
          else if 1 = length vs' then Some (fm, [], true_RRn ℱ 0)
          else Some (fm, upd_bruijn vs', rrn_drop_fst tas')
    }
    | IRename l' vs ⇒ guard (l' < l) ⪢ None
    | INNFPlus l' ⇒ do {
        guard (l' < l);
        let fm' = fst (infs ! l');
        guard (ord_form_list_aci (nnf_to_list_aci (nnf (form_of_formula fm'))) = ord_form_list_aci (nnf_to_list_aci (nnf (form_of_formula fm))));
        Some (fm, snd (infs ! l'))
    }
    | IRepl eq pos l' ⇒ guard (l' < l) ⪢ None
    }"

lemma RRn_spec_true_RRn:
  "RRn_spec (Suc 0) (true_RRn ℱ (Suc 0)) {[t] |t. t ∈ 𝒯G (fset ℱ)}"
  apply (auto simp: RRn_spec_def 𝒯G_equivalent_def fmap_funs_ℒ
      image_def term_automaton[of ℱ, unfolded RR1_spec_def])
   apply (metis gencode_singleton)+
  done

lemma check_inference_correct:
  assumes sig: "𝒯G (fset ℱ) ≠ {}" and Rs: "∀R ∈ set Rs. lv_trs (fset R) ∧ ffunas_trs R |⊆| ℱ"
  assumes infs: "⋀fvA. fvA ∈ set infs ⟹ formula_spec (fset ℱ) (map fset Rs) (fst (snd fvA)) (snd (snd fvA)) (fst fvA)"
  assumes inf: "check_inference rr1c rr2c ℱ Rs infs (l, step, fm, is) = Some (fm', vs, A')"
  assumes rr1: "⋀r1. ∀ta1. rr1c ℱ Rs r1 = Some ta1 ⟶ RR1_spec ta1 (eval_rr1_rel (fset ℱ) (map fset Rs) r1)"
  assumes rr2: "⋀r2. ∀ta2. rr2c ℱ Rs r2 = Some ta2 ⟶ RR2_spec ta2 (eval_rr2_rel (fset ℱ) (map fset Rs) r2)"
  shows "l = length infs ∧ fm = fm' ∧ formula_spec (fset ℱ) (map fset Rs) vs A' fm'"
  using inf
proof (induct step)
  note [simp] = bind_eq_Some_conv guard_simps
  let ?F = "fset ℱ" let ?Rs = "map fset Rs"
{
  case (IRR1 s x)
  then show ?case
    using rr1[rule_format, of s]
    subsetD[OF eval_rr12_rel_sig(1), of _ ?F ?Rs s]
    by (force simp: formula_spec_def formula_relevant_def RR1_spec_def 𝒯G_equivalent_def
      intro!: RR1_to_RRn_spec[of _ "(λα. α x) ` Collect P" for P, unfolded image_comp, unfolded image_Collect comp_def One_nat_def])
next
  case (IRR2 r x y)
  then show ?case using rr2[rule_format, of r]
    subsetD[OF eval_rr12_rel_sig(2), of _ ?F ?Rs r]
    two_comparisons_into_compare(1)[of x y "x = y" "x < y" "x > y"]
  proof (induct "compare x y")
    note [intro!] = RR1_to_RRn_spec[of _ "(λα. α y) ` Collect P" for P, unfolded image_comp,
      unfolded image_Collect comp_def One_nat_def prod.simps]
    case Eq
    then obtain A where w[simp]: "rr2c ℱ Rs r = Some A" by auto
    from Eq obtain B where [simp]:"rr2c ℱ Rs (R2Diag R1Terms) = Some B" by auto
    let ?B = "reg_intersect A B"
    from Eq(3)[OF w] have "RR2_spec ?B (eval_rr2_rel ?F ?Rs r ∩ Restr Id (𝒯G ?F))"
      using rr2[rule_format, of "R2Diag R1Terms" B]
      by (auto simp add: ℒ_intersect RR2_spec_def dest: lift_fun_gpairD)
    then have "RR2_spec (relabel_reg (trim_reg ?B)) (eval_rr2_rel ?F ?Rs r ∩ Restr Id (𝒯G ?F))" by simp
    from proj_1(1)[OF this]
    have "RR1_spec (proj_1_reg (relabel_reg (trim_reg ?B))) {α y |α. range α ⊆ gterms ?F ∧ (α y, α y) ∈ eval_rr2_rel ?F ?Rs r}"
      apply (auto simp: RR1_spec_def 𝒯G_equivalent_def image_iff)
      by (metis Eq.prems(3) IdI IntI 𝒯G_equivalent_def fst_conv) 
    then show ?thesis using Eq
      by (auto simp: formula_spec_def formula_relevant_def liftO1_def 𝒯G_equivalent_def simplify_reg_def RR2_spec_def
      split: if_splits intro!: exI[of _ "λz. if z = x then _ else _"])
  next
    note [intro!] = RR2_to_RRn_spec[of _ "(λα. (α x, α y)) ` Collect P" for P, unfolded image_comp,
      unfolded image_Collect comp_def numeral_2_eq_2 prod.simps]
    case Lt then show ?thesis by (fastforce simp: formula_spec_def formula_relevant_def RR2_spec_def 𝒯G_equivalent_def
      split: if_splits intro!: exI[of _ "λz. if z = x then _ else _"])
  next
    note [intro!] = RR2_to_RRn_spec[of _ "prod.swap ` (λα. (α x, α y)) ` Collect P" for P, OF swap_RR2_spec,
      unfolded image_comp, unfolded image_Collect comp_def numeral_2_eq_2 prod.simps fmap_funs_reg_comp case_swap]
    case Gt then show ?thesis
      by (fastforce simp: formula_spec_def formula_relevant_def RR2_spec_def 𝒯G_equivalent_def
        split: if_splits intro!: exI[of _ "λz. if z = x then _ else _"])
  qed
next
  case (IAnd ls)
  have [simp]: "(fm, vs, ta) ∈ (!) infs ` set ls ⟹ formula_spec ?F ?Rs vs ta fm" for fm vs ta
    using infs IAnd by auto
  show ?case using IAnd fit_rrns[OF assms(3), of "map ((!) infs) ls", OF _ prod.collapse]
    by (force split: prod.splits intro!: fand_rrn[OF assms(1)])
next
  case (IOr ls)
  have [simp]: "(fm, vs, ta) ∈ (!) infs ` set ls ⟹ formula_spec ?F ?Rs vs ta fm" for fm vs ta
    using infs IOr by auto
  show ?case using IOr fit_rrns[OF assms(3), of "map ((!) infs) ls", OF _ prod.collapse]
    by (force split: prod.splits intro!: for_rrn)
next
  case (INot l')
  obtain fm vs' ta where [simp]: "infs ! l' = (fm, vs', ta)" by (cases "infs ! l'") auto
  then have spec: "formula_spec ?F ?Rs vs ta fm" using infs[OF nth_mem, of l'] INot
    by auto
  have rel: "formula_relevant (fset ℱ) (map fset Rs) vs (FNot fm)" using spec
    unfolding formula_spec_def formula_relevant_def
    by (metis (no_types, lifting) eval_formula.simps(5))
  have vs: "sorted vs" "distinct vs" using spec by (auto simp: formula_spec_def)
  {fix xs assume ass: "∀α. range α ⊆ 𝒯G (fset ℱ) ⟶ xs = map α vs ⟶ ¬ eval_formula (fset ℱ) (map fset Rs) α fm"
    "length xs = length vs" "set xs ⊆ 𝒯G (fset ℱ)"
    from sig obtain s where mem: "s ∈ 𝒯G (fset ℱ)" by blast
    let ?g = "λ i. find (λ p. fst p = i) (zip vs [0 ..< length vs])"
    let ?f = "λ i. if ?g i = None then s else xs ! snd (the (?g i))"
    from vs(1) have *: "sorted (zip vs [0 ..< length vs])"
      by (induct vs rule: rev_induct) (auto simp: sorted_append elim!: in_set_zipE intro!: sorted_append_bigger)
    have "i < length vs ⟹ ?g (vs ! i) = Some (vs ! i, i)" for i using vs(2)
      by (induct vs rule: rev_induct) (auto simp: nth_append find_append find_Some_iff nth_eq_iff_index_eq split!: if_splits)
    then have "map ?f vs = xs" using vs(2) ass(2)
      by (intro nth_equalityI) (auto simp: find_None_iff set_zip)
    moreover have "range ?f ⊆ 𝒯G (fset ℱ)" using ass(2, 3) mem
      using find_SomeD(2) set_zip_rightD by auto fastforce
    ultimately have "∃α. xs = map α vs ∧ range α ⊆ 𝒯G (fset ℱ) ∧ ¬ eval_formula (fset ℱ) (map fset Rs) α fm" using ass(1)
      by (intro exI[of _ ?f]) auto}
  then have *: "{ts. length ts = length vs ∧ set ts ⊆ 𝒯G (fset ℱ)} -
    {map α vs |α. range α ⊆ 𝒯G (fset ℱ) ∧ eval_formula (fset ℱ) (map fset Rs) α fm} =
    {map α vs |α. range α ⊆ 𝒯G (fset ℱ) ∧ ¬ eval_formula (fset ℱ) (map fset Rs) α fm}"
    apply auto
    apply force
    using formula_relevantD[OF rel] unfolding eval_formula.simps
    by (meson map_ext)
  have "RRn_spec (length vs) (difference_reg (true_RRn ℱ (length vs)) ta)
     {map α vs |α. range α ⊆ 𝒯G (fset ℱ) ∧ ¬ eval_formula (fset ℱ) (map fset Rs) α fm}"
    using RRn_difference[OF true_RRn_spec[of "length vs" ℱ] formula_spec_RRn_spec[OF spec]]
    unfolding * by simp
  then show ?case using INot spec rel
    by (auto split: prod.splits simp: formula_spec_def)
next
  case (IExists l')
  obtain fm vs ta where [simp]: "infs ! l' = (fm, vs, ta)" by (cases "infs ! l'") auto
  then have spec: "formula_spec ?F ?Rs vs ta fm" using infs[OF nth_mem, of l'] IExists
    by auto
  show ?case
  proof (cases "length vs = 0")
    case True
    then show ?thesis using IExists spec
      apply (auto simp: formula_spec_def)
      subgoal apply (auto simp: formula_relevant_def)
        apply (meson shift_rangeI)
        done
      subgoal apply (auto simp: RRn_spec_def image_iff)
        apply (meson eval_formula_shift_right_eval(1) rangeI shift_right_rangeI subsetD)
        apply (meson shift_rangeI)
        done
      done
  next
    case False note len = this
    then have *[simp]: "vs ≠ []" by (cases vs) auto 
    show ?thesis
    proof (cases "reg_empty ta")
      case True
      then show ?thesis using IExists spec formula_spec_empty[OF _ spec]
        by (auto simp: 𝒯G_equivalent_def comp_def formula_spec_def
                        shift_rangeI RRn_spec_def image_iff ℒ_epmty
               intro!: trivial_formula_relevant)
    next
      case False
      then have nt_empty [simp]: "ℒ ta ≠ {}" by auto
      show ?thesis
      proof (cases "0 ∉ set vs")
        case True
        then have ta: "ta = A'" using spec IExists
          by (auto simp: formula_spec_def)
        from True have relv: "formula_relevant ?F ?Rs (map (λx. x - Suc 0) vs) (FExists fm)"
          using spec IExists
          by (intro ExistsI_upd_brujin_no_0) (auto simp: formula_spec_def)
        then show ?thesis using True spec IExists nt_rel_0_trivial_shift[OF True, of ?F ?Rs ]
          by (auto simp: formula_spec_def 𝒯G_equivalent_def comp_def
                   elim!: formula_relevantD
                   intro!: pres_distinct_not_0_list_dec pres_sorted_dec)
      next
        case False
        then have rel_0: "0 ∈ set vs" by simp
        show ?thesis
        proof (cases "1 = length vs")
          case True
          then have [simp]: "vs = [0]" using rel_0 by (induct vs) auto
          {fix t assume "0 |∈| ta_der (TA {|[] [] → 0|} {||}) (term_of_gterm t)"
            then have "t = GFun [] []" by (cases t) auto}
          then have [simp]: "ℒ (Reg {|0|} (TA {|TA_rule [] [] 0|} {||})) = {GFun [] []}"
            by (auto simp: ℒ_def gta_der_def gta_lang_def)
          have [simp]: "GFun [] [] = gencode []"
            by (auto simp: gencode_def gunions_def)
          show ?thesis using IExists spec nt_empty
            by (auto simp: formula_spec_def RRn_spec_true_RRn RRn_spec_def formula_relevant_0_FExists image_iff)
               (meson eval_formula_shift_right_eval(1) in_mono rangeI shift_right_rangeI)
        next
          case False
          from False show ?thesis using spec IExists rel_0 nt_empty
            using rrn_drop_fst_lang[OF formula_spec_RRn_spec[OF spec]]
            by (auto simp: formula_spec_def Suc_lessI simp flip: drop_upd_bruijn_set
                     split: prod.splits
                     intro: upd_bruijn_pres_sorted upd_bruijn_pres_distinct ExistsI_upd_brujin_0)
        qed
      qed
    qed
  qed
next
  case (IRename l' vs)
  then show ?case by simp
next
  case (INNFPlus l')
  show ?case using infs[OF nth_mem, of l'] INNFPlus
    apply (auto simp: formula_spec_def formula_relevant_def eval_formula_conv)
    apply (simp_all only: check_equivalence_by_nnf_sortedlist_aci[of "form_of_formula (fst (infs ! l'))" "form_of_formula fm"])
    done
next
  case (IRepl eq pos l')
  then show ?case by simp
}
qed


end
body>

Theory FOR_Check_Impl

theory FOR_Check_Impl
  imports FOR_Check
   Regular_Tree_Relations.Regular_Relation_Impl
   NF_Impl
begin

section ‹Inference checking implementation›

(* we define epsilon free agtt/gtt constructions *)
definition "ftrancl_eps_free_closures 𝒜 = eps_free_automata (eps 𝒜) 𝒜"
abbreviation "ftrancl_eps_free_reg 𝒜 ≡ Reg (fin 𝒜) (ftrancl_eps_free_closures (ta 𝒜))"

lemma ftrancl_eps_free_ta_derI:
  "(eps 𝒜)|+| = eps 𝒜 ⟹ ta_der (ftrancl_eps_free_closures 𝒜) (term_of_gterm t) = ta_der 𝒜 (term_of_gterm t)"
  using eps_free[of 𝒜] ta_res_eps_free[of 𝒜]
  by (auto simp add: ftrancl_eps_free_closures_def)

lemma ℒ_ftrancl_eps_free_closuresI:
  "(eps (ta 𝒜))|+| = eps (ta 𝒜) ⟹ ℒ (ftrancl_eps_free_reg 𝒜) = ℒ 𝒜"
  using ftrancl_eps_free_ta_derI[of "ta 𝒜"]
  unfolding ℒ_def by (auto simp: gta_lang_def gta_der_def)

definition "root_step R ℱ ≡ (let (TA1, TA2) = agtt_grrstep R ℱ in
  (ftrancl_eps_free_closures TA1, TA2))"

definition AGTT_trancl_eps_free :: "('q, 'f) gtt ⇒ ('q + 'q, 'f) gtt" where
  "AGTT_trancl_eps_free 𝒢 = (let (𝒜, ℬ) = AGTT_trancl 𝒢 in
    (ftrancl_eps_free_closures 𝒜, ℬ))"

definition GTT_trancl_eps_free where
  "GTT_trancl_eps_free 𝒢 = (let (𝒜, ℬ) = GTT_trancl 𝒢 in
   (ftrancl_eps_free_closures 𝒜,
    ftrancl_eps_free_closures ℬ))"

definition AGTT_comp_eps_free where
  "AGTT_comp_eps_free 𝒢1 𝒢2 = (let (𝒜, ℬ) = AGTT_comp' 𝒢1 𝒢2 in
    (ftrancl_eps_free_closures 𝒜, ℬ))"

definition GTT_comp_eps_free where
  "GTT_comp_eps_free 𝒢1 𝒢2 =(let (𝒜, ℬ) = GTT_comp' 𝒢1 𝒢2 in
    (ftrancl_eps_free_closures 𝒜, ftrancl_eps_free_closures ℬ))"

(* epsilon free proves *)
lemma eps_free_relable [simp]:
  "is_gtt_eps_free (relabel_gtt 𝒢) = is_gtt_eps_free 𝒢"
  by (auto simp: is_gtt_eps_free_def relabel_gtt_def fmap_states_gtt_def fmap_states_ta_def)

lemma eps_free_prod_swap:
  "is_gtt_eps_free (𝒜, ℬ) ⟹ is_gtt_eps_free (ℬ, 𝒜)"
  by (auto simp: is_gtt_eps_free_def)

lemma eps_free_root_step:
  "is_gtt_eps_free (root_step R ℱ)"
  by (auto simp add: case_prod_beta is_gtt_eps_free_def root_step_def pair_at_to_agtt'_def ftrancl_eps_free_closures_def)

lemma eps_free_AGTT_trancl_eps_free:
  "is_gtt_eps_free 𝒢 ⟹ is_gtt_eps_free (AGTT_trancl_eps_free 𝒢)"
  by (auto simp: case_prod_beta is_gtt_eps_free_def AGTT_trancl_def Let_def
      AGTT_trancl_eps_free_def ftrancl_eps_free_closures_def)

lemma eps_free_GTT_trancl_eps_free:
  "is_gtt_eps_free 𝒢 ⟹ is_gtt_eps_free (GTT_trancl_eps_free 𝒢)"
  by (auto simp: case_prod_beta is_gtt_eps_free_def GTT_trancl_eps_free_def ftrancl_eps_free_closures_def)

lemma eps_free_AGTT_comp_eps_free:
  "is_gtt_eps_free 𝒢2 ⟹ is_gtt_eps_free (AGTT_comp_eps_free 𝒢1 𝒢2)"
  by (auto simp: case_prod_beta is_gtt_eps_free_def AGTT_comp_eps_free_def
    ftrancl_eps_free_closures_def AGTT_comp_def fmap_states_gtt_def fmap_states_ta_def)

lemma eps_free_GTT_comp_eps_free:
  "is_gtt_eps_free (GTT_comp_eps_free 𝒢1 𝒢2)"
  by (auto simp: case_prod_beta is_gtt_eps_free_def GTT_comp_eps_free_def ftrancl_eps_free_closures_def)

lemmas eps_free_const =
  eps_free_prod_swap
  eps_free_root_step
  eps_free_AGTT_trancl_eps_free
  eps_free_GTT_trancl_eps_free
  eps_free_AGTT_comp_eps_free
  eps_free_GTT_comp_eps_free

(* lang preserve proofs *)
lemma agtt_lang_derI:
  assumes "⋀ t. ta_der (fst 𝒜) (term_of_gterm t) = ta_der (fst ℬ) (term_of_gterm t)"
    and "⋀ t. ta_der (snd 𝒜) (term_of_gterm t) = ta_der (snd ℬ) (term_of_gterm t)"
  shows "agtt_lang 𝒜 = agtt_lang ℬ" using assms
  by (auto simp: agtt_lang_def gta_der_def)

lemma agtt_lang_root_step_conv:
  "agtt_lang (root_step R ℱ) = agtt_lang (agtt_grrstep R ℱ)"
  using ftrancl_eps_free_ta_derI[OF agtt_grrstep_eps_trancl(1), of R ℱ]
  by (auto simp: case_prod_beta root_step_def intro!: agtt_lang_derI)

lemma agtt_lang_AGTT_trancl_eps_free_conv:
  assumes "is_gtt_eps_free 𝒢"
  shows "agtt_lang (AGTT_trancl_eps_free 𝒢) = agtt_lang (AGTT_trancl 𝒢)"
proof -
  let ?eps = "eps (fst (AGTT_trancl 𝒢))"
  have "?eps |O| ?eps = {||}" using assms
    by (auto simp: AGTT_trancl_def is_gtt_eps_free_def Let_def fmap_states_ta_def)
  from ftrancl_eps_free_ta_derI[OF frelcomp_empty_ftrancl_simp[OF this]]
  show ?thesis
    by (auto simp: case_prod_beta AGTT_trancl_eps_free_def intro!: agtt_lang_derI)
qed

lemma agtt_lang_GTT_trancl_eps_free_conv:
  assumes "is_gtt_eps_free 𝒢"
  shows "agtt_lang (GTT_trancl_eps_free 𝒢) = agtt_lang (GTT_trancl 𝒢)"
proof -
  have "(eps (fst (GTT_trancl 𝒢)))|+| = eps (fst (GTT_trancl 𝒢))"
    "(eps (snd (GTT_trancl 𝒢)))|+| = eps (snd (GTT_trancl 𝒢))" using assms
    by (auto simp: GTT_trancl_def Let_def is_gtt_eps_free_def Δ_trancl_inv)
  from ftrancl_eps_free_ta_derI[OF this(1)] ftrancl_eps_free_ta_derI[OF this(2)]
  show ?thesis
    by (auto simp: case_prod_beta GTT_trancl_eps_free_def intro!: agtt_lang_derI)
qed

lemma agtt_lang_AGTT_comp_eps_free_conv:
  assumes "is_gtt_eps_free 𝒢1" "is_gtt_eps_free 𝒢2"
  shows "agtt_lang (AGTT_comp_eps_free 𝒢1 𝒢2) = agtt_lang (AGTT_comp' 𝒢1 𝒢2)"
proof -
  have "(eps (fst (AGTT_comp' 𝒢1 𝒢2)))|+| = eps (fst (AGTT_comp' 𝒢1 𝒢2))" using assms
    by (auto simp: is_gtt_eps_free_def fmap_states_gtt_def fmap_states_ta_def
      case_prod_beta AGTT_comp_def gtt_interface_def 𝒬_def intro!: frelcomp_empty_ftrancl_simp)
  from ftrancl_eps_free_ta_derI[OF this] show ?thesis
    by (auto simp: case_prod_beta AGTT_comp_eps_free_def intro!: agtt_lang_derI)
qed

lemma agtt_lang_GTT_comp_eps_free_conv:
  assumes "is_gtt_eps_free 𝒢1" "is_gtt_eps_free 𝒢2"
  shows "agtt_lang (GTT_comp_eps_free 𝒢1 𝒢2) = agtt_lang (GTT_comp' 𝒢1 𝒢2)"
proof -
  have "(eps (fst (GTT_comp' 𝒢1 𝒢2)))|+| = eps (fst (GTT_comp' 𝒢1 𝒢2))"
    "(eps (snd (GTT_comp' 𝒢1 𝒢2)))|+| = eps (snd (GTT_comp' 𝒢1 𝒢2))" using assms
    by (auto simp: is_gtt_eps_free_def fmap_states_gtt_def fmap_states_ta_def Δε_fmember
      case_prod_beta GTT_comp_def gtt_interface_def 𝒬_def dest!: ground_ta_der_statesD
      intro!: frelcomp_empty_ftrancl_simp)
  from ftrancl_eps_free_ta_derI[OF this(1)] ftrancl_eps_free_ta_derI[OF this(2)]
  show ?thesis
    by (auto simp: case_prod_beta GTT_comp_eps_free_def intro!: agtt_lang_derI)
qed

fun gtt_of_gtt_rel_impl :: "('f × nat) fset ⇒ ('f :: linorder, 'v) fin_trs list ⇒ ftrs gtt_rel ⇒ (nat, 'f) gtt option" where
  "gtt_of_gtt_rel_impl ℱ Rs (ARoot is) = liftO1 (λR. relabel_gtt (root_step R ℱ)) (is_to_trs' Rs is)"
| "gtt_of_gtt_rel_impl ℱ Rs (GInv g) = liftO1 prod.swap (gtt_of_gtt_rel_impl ℱ Rs g)"
| "gtt_of_gtt_rel_impl ℱ Rs (AUnion g1 g2) = liftO2 (λg1 g2. relabel_gtt (AGTT_union' g1 g2)) (gtt_of_gtt_rel_impl ℱ Rs g1) (gtt_of_gtt_rel_impl ℱ Rs g2)"
| "gtt_of_gtt_rel_impl ℱ Rs (ATrancl g) = liftO1 (relabel_gtt ∘ AGTT_trancl_eps_free) (gtt_of_gtt_rel_impl ℱ Rs g)"
| "gtt_of_gtt_rel_impl ℱ Rs (GTrancl g) = liftO1 GTT_trancl_eps_free (gtt_of_gtt_rel_impl ℱ Rs g)"
| "gtt_of_gtt_rel_impl ℱ Rs (AComp g1 g2) = liftO2 (λg1 g2. relabel_gtt (AGTT_comp_eps_free g1 g2)) (gtt_of_gtt_rel_impl ℱ Rs g1) (gtt_of_gtt_rel_impl ℱ Rs g2)"
| "gtt_of_gtt_rel_impl ℱ Rs (GComp g1 g2) = liftO2 (λg1 g2. relabel_gtt (GTT_comp_eps_free g1 g2)) (gtt_of_gtt_rel_impl ℱ Rs g1) (gtt_of_gtt_rel_impl ℱ Rs g2)"

lemma gtt_of_gtt_rel_impl_is_gtt_eps_free:
  "gtt_of_gtt_rel_impl ℱ Rs g = Some g' ⟹ is_gtt_eps_free g'"
proof (induct g arbitrary: g')
  case (AUnion g1 g2)
  then show ?case
    by (auto simp: is_gtt_eps_free_def AGTT_union_def fmap_states_gtt_def fmap_states_ta_def ta_union_def relabel_gtt_def)
qed (auto simp: eps_free_const)

lemma gtt_of_gtt_rel_impl_gtt_of_gtt_rel:
  "gtt_of_gtt_rel_impl ℱ Rs g ≠ None ⟷ gtt_of_gtt_rel ℱ Rs g ≠ None" (is "?Ls ⟷ ?Rs")
proof -
  have "?Ls ⟹ ?Rs" by (induct g) auto
  moreover have "?Rs ⟹ ?Ls" by (induct g) auto
  ultimately show ?thesis by blast
qed

lemma gtt_of_gtt_rel_impl_sound:
  "gtt_of_gtt_rel_impl ℱ Rs g = Some g' ⟹ gtt_of_gtt_rel ℱ Rs g = Some g'' ⟹ agtt_lang g' = agtt_lang g''"
proof (induct g arbitrary: g' g'')
  case (ARoot x)
  then show ?case by (simp add: agtt_lang_root_step_conv)
next
  case (GInv g)
  then have "agtt_lang (prod.swap g') = agtt_lang (prod.swap g'')" by auto
  then show ?case
    by (metis converse_agtt_lang converse_converse)
next
  case (AUnion g1 g2)
  then show ?case
    by simp (metis AGTT_union'_sound option.sel)
next
  case (ATrancl g)
  then show ?case
    using agtt_lang_AGTT_trancl_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of ℱ Rs g]
    by simp (metis AGTT_trancl_sound option.sel)
next
  case (GTrancl g)
  then show ?case
    using agtt_lang_GTT_trancl_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of ℱ Rs g]
    by simp (metis GTT_trancl_alang option.sel) 
next
  case (AComp g1 g2)
  then show ?case
    using agtt_lang_AGTT_comp_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of ℱ Rs g
      "the (gtt_of_gtt_rel_impl ℱ Rs g1)" "the (gtt_of_gtt_rel_impl ℱ Rs g2)"]
    by simp (metis AGTT_comp'_sound agtt_lang_AGTT_comp_eps_free_conv gtt_of_gtt_rel_impl_is_gtt_eps_free option.sel) 
next
  case (GComp g1 g2)
  then show ?case
    using agtt_lang_GTT_comp_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of ℱ Rs g
      "the (gtt_of_gtt_rel_impl ℱ Rs g1)" "the (gtt_of_gtt_rel_impl ℱ Rs g2)"]
    by simp (metis agtt_lang_GTT_comp_eps_free_conv gtt_comp'_alang gtt_of_gtt_rel_impl_is_gtt_eps_free option.sel) 
qed

(* eps free closure constructions *)
lemma ℒ_eps_free_nhole_ctxt_closure_reg:
  assumes "is_ta_eps_free (ta 𝒜)"
  shows "ℒ (ftrancl_eps_free_reg (nhole_ctxt_closure_reg ℱ 𝒜)) = ℒ (nhole_ctxt_closure_reg ℱ 𝒜)"
proof -
  have "eps (ta (nhole_ctxt_closure_reg ℱ 𝒜)) |O| eps (ta (nhole_ctxt_closure_reg ℱ 𝒜)) = {||}" using assms
    by (auto simp: nhole_ctxt_closure_reg_def gen_nhole_ctxt_closure_reg_def
      gen_nhole_ctxt_closure_automaton_def ta_union_def reflcl_over_nhole_ctxt_ta_def
      fmap_states_reg_def is_ta_eps_free_def fmap_states_ta_def reg_Restr_Qf_def)
  from frelcomp_empty_ftrancl_simp[OF this] show ?thesis
    by (intro ℒ_ftrancl_eps_free_closuresI) simp
qed

lemma ℒ_eps_free_ctxt_closure_reg:
  assumes "is_ta_eps_free (ta 𝒜)"
  shows "ℒ (ftrancl_eps_free_reg (ctxt_closure_reg ℱ 𝒜)) = ℒ (ctxt_closure_reg ℱ 𝒜)"
proof -
  have "eps (ta (ctxt_closure_reg ℱ 𝒜)) |O| eps (ta (ctxt_closure_reg ℱ 𝒜)) = {||}" using assms
    by (auto simp: ctxt_closure_reg_def gen_ctxt_closure_reg_def Let_def
      gen_ctxt_closure_automaton_def ta_union_def reflcl_over_single_ta_def
      fmap_states_reg_def is_ta_eps_free_def fmap_states_ta_def reg_Restr_Qf_def)
  from frelcomp_empty_ftrancl_simp[OF this] show ?thesis
    by (intro ℒ_ftrancl_eps_free_closuresI) simp
qed

lemma ℒ_eps_free_parallel_closure_reg:
  assumes "is_ta_eps_free (ta 𝒜)"
  shows "ℒ (ftrancl_eps_free_reg (parallel_closure_reg ℱ 𝒜)) = ℒ (parallel_closure_reg ℱ 𝒜)"
proof -
  have "eps (ta (parallel_closure_reg ℱ 𝒜)) |O| eps (ta (parallel_closure_reg ℱ 𝒜)) = {||}" using assms
    by (auto simp: parallel_closure_reg_def gen_parallel_closure_automaton_def Let_def ta_union_def
      refl_over_states_ta_def fmap_states_reg_def is_ta_eps_free_def fmap_states_ta_def reg_Restr_Qf_def)
  from frelcomp_empty_ftrancl_simp[OF this] show ?thesis
    by (intro ℒ_ftrancl_eps_free_closuresI) simp
qed

abbreviation "eps_free_reg' S R ≡ Reg (fin R) (eps_free_automata S (ta R))"

definition "eps_free_mctxt_closure_reg ℱ 𝒜 =
  (let ℬ = mctxt_closure_reg ℱ 𝒜 in
  eps_free_reg' ((λ p. (fst p, Inr cl_state)) |`| (eps (ta ℬ)) |∪| eps (ta ℬ)) ℬ)"

definition "eps_free_nhole_mctxt_reflcl_reg ℱ 𝒜 =
  (let ℬ = nhole_mctxt_reflcl_reg ℱ 𝒜 in
  eps_free_reg' ((λ p. (fst p, Inl (Inr cl_state))) |`| (eps (ta ℬ)) |∪| eps (ta ℬ)) ℬ)"

definition "eps_free_nhole_mctxt_closure_reg ℱ 𝒜 =
  (let ℬ = nhole_mctxt_closure_reg ℱ 𝒜 in
  eps_free_reg' ((λ p. (fst p, (Inr cl_state))) |`| (eps (ta ℬ)) |∪| eps (ta ℬ)) ℬ)"

lemma ℒ_eps_free_reg'I:
  "(eps (ta 𝒜))|+| = S ⟹ ℒ (eps_free_reg' S 𝒜) = ℒ 𝒜"
  by (auto simp:  ℒ_def gta_lang_def gta_der_def ta_res_eps_free simp flip: eps_free) 

lemma ℒ_eps_free_mctxt_closure_reg:
  assumes "is_ta_eps_free (ta 𝒜)"
  shows "ℒ (eps_free_mctxt_closure_reg ℱ 𝒜) = ℒ (mctxt_closure_reg ℱ 𝒜)" using assms
  unfolding eps_free_mctxt_closure_reg_def Let_def
  apply (intro ℒ_eps_free_reg'I)
  apply (auto simp: comp_def mctxt_closure_reg_def is_ta_eps_free_def Let_def
    gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def ta_union_def
    reflcl_over_nhole_ctxt_ta_def  gen_mctxt_closure_reg_def reg_Restr_Qf_def
    fmap_states_reg_def fmap_states_ta_def dest: ftranclD ftranclD2)
  by (meson fimageI finsert_iff finterI fr_into_trancl ftrancl_into_trancl)

lemma ℒ_eps_free_nhole_mctxt_reflcl_reg:
  assumes "is_ta_eps_free (ta 𝒜)"
  shows "ℒ (eps_free_nhole_mctxt_reflcl_reg ℱ 𝒜) = ℒ (nhole_mctxt_reflcl_reg ℱ 𝒜)" using assms
  unfolding eps_free_nhole_mctxt_reflcl_reg_def Let_def
  apply (intro ℒ_eps_free_reg'I)
  apply (auto simp: comp_def nhole_mctxt_reflcl_reg_def is_ta_eps_free_def Let_def
    nhole_mctxt_closure_reg_def gen_nhole_mctxt_closure_reg_def reg_union_def ta_union_def
    gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def
    reflcl_over_nhole_ctxt_ta_def reg_Restr_Qf_def fmap_states_reg_def fmap_states_ta_def dest: ftranclD ftranclD2)
  by (meson fimageI finsert_iff finterI fr_into_trancl ftrancl_into_trancl)

lemma ℒ_eps_free_nhole_mctxt_closure_reg:
  assumes "is_ta_eps_free (ta 𝒜)"
  shows "ℒ (eps_free_nhole_mctxt_closure_reg ℱ 𝒜) = ℒ (nhole_mctxt_closure_reg ℱ 𝒜)" using assms
  unfolding eps_free_nhole_mctxt_closure_reg_def Let_def
  apply (intro ℒ_eps_free_reg'I)
  apply (auto simp: comp_def nhole_mctxt_closure_reg_def is_ta_eps_free_def Let_def
    gen_nhole_mctxt_closure_reg_def reg_Restr_Qf_def fmap_states_reg_def fmap_states_ta_def
    gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def ta_union_def
    reflcl_over_nhole_ctxt_ta_def dest: ftranclD ftranclD2)
  by (meson fimageI finsert_iff finterI fr_into_trancl ftrancl_into_trancl)

fun rr1_of_rr1_rel_impl :: "('f × nat) fset ⇒ ('f :: linorder, 'v) fin_trs list ⇒ ftrs rr1_rel ⇒ (nat, 'f) reg option"
and rr2_of_rr2_rel_impl :: "('f × nat) fset ⇒ ('f, 'v) fin_trs list ⇒ ftrs rr2_rel ⇒ (nat, 'f option × 'f option) reg option" where
  "rr1_of_rr1_rel_impl ℱ Rs R1Terms = Some (relabel_reg (term_reg ℱ))"
| "rr1_of_rr1_rel_impl ℱ Rs (R1NF is) = liftO1 (λR. (simplify_reg (nf_reg (fst |`| R) ℱ))) (is_to_trs' Rs is)"
| "rr1_of_rr1_rel_impl ℱ Rs (R1Inf r) = liftO1 (λR.
    let 𝒜 = trim_reg R in
    simplify_reg (proj_1_reg (Inf_reg_impl 𝒜))
  ) (rr2_of_rr2_rel_impl ℱ Rs r)"
| "rr1_of_rr1_rel_impl ℱ Rs (R1Proj i r) = (case i of 0 ⇒
      liftO1 (trim_reg ∘ proj_1_reg) (rr2_of_rr2_rel_impl ℱ Rs r)
    | _ ⇒ liftO1 (trim_reg ∘ proj_2_reg) (rr2_of_rr2_rel_impl ℱ Rs r))"
| "rr1_of_rr1_rel_impl ℱ Rs (R1Union s1 s2) =
    liftO2 (λ x y. relabel_reg (reg_union x y)) (rr1_of_rr1_rel_impl ℱ Rs s1) (rr1_of_rr1_rel_impl ℱ Rs s2)"
| "rr1_of_rr1_rel_impl ℱ Rs (R1Inter s1 s2) =
    liftO2 (λ x y. simplify_reg (reg_intersect x y)) (rr1_of_rr1_rel_impl ℱ Rs s1) (rr1_of_rr1_rel_impl ℱ Rs s2)"
| "rr1_of_rr1_rel_impl ℱ Rs (R1Diff s1 s2) = liftO2 (λ x y. relabel_reg (trim_reg (difference_reg x y))) (rr1_of_rr1_rel_impl ℱ Rs s1) (rr1_of_rr1_rel_impl ℱ Rs s2)"

| "rr2_of_rr2_rel_impl ℱ Rs (R2GTT_Rel g w x) =
    (case w of PRoot ⇒
      (case x of ESingle ⇒ liftO1 (simplify_reg ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl ℱ Rs g)
        | EParallel ⇒ liftO1 (simplify_reg ∘ reflcl_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl ℱ Rs g)
        | EStrictParallel ⇒ liftO1 (simplify_reg ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl ℱ Rs g))
      | PNonRoot ⇒
      (case x of ESingle ⇒ liftO1 (simplify_reg ∘ ftrancl_eps_free_reg ∘ nhole_ctxt_closure_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl ℱ Rs g)
        | EParallel ⇒ liftO1 (simplify_reg ∘ eps_free_nhole_mctxt_reflcl_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl ℱ Rs g)
        | EStrictParallel ⇒ liftO1 (simplify_reg ∘ eps_free_nhole_mctxt_closure_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl ℱ Rs g))
      | PAny ⇒
      (case x of ESingle ⇒ liftO1 (simplify_reg ∘ ftrancl_eps_free_reg ∘ ctxt_closure_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl ℱ Rs g)
        | EParallel ⇒ liftO1 (simplify_reg ∘ ftrancl_eps_free_reg ∘ parallel_closure_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl ℱ Rs g)
        | EStrictParallel ⇒ liftO1 (simplify_reg ∘ eps_free_mctxt_closure_reg (lift_sig_RR2 |`| ℱ) ∘ GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl ℱ Rs g)))"
| "rr2_of_rr2_rel_impl ℱ Rs (R2Diag s) =
    liftO1 (λ x. fmap_funs_reg (λf. (Some f, Some f)) x) (rr1_of_rr1_rel_impl ℱ Rs s)"
| "rr2_of_rr2_rel_impl ℱ Rs (R2Prod s1 s2) =
    liftO2 (λ x y. simplify_reg (pair_automaton_reg x y)) (rr1_of_rr1_rel_impl ℱ Rs s1) (rr1_of_rr1_rel_impl ℱ Rs s2)"
| "rr2_of_rr2_rel_impl ℱ Rs (R2Inv r) = liftO1 (fmap_funs_reg prod.swap) (rr2_of_rr2_rel_impl ℱ Rs r)"
| "rr2_of_rr2_rel_impl ℱ Rs (R2Union r1 r2) =
    liftO2 (λ x y. relabel_reg (reg_union x y)) (rr2_of_rr2_rel_impl ℱ Rs r1) (rr2_of_rr2_rel_impl ℱ Rs r2)"
| "rr2_of_rr2_rel_impl ℱ Rs (R2Inter r1 r2) =
    liftO2 (λ x y. simplify_reg (reg_intersect x y)) (rr2_of_rr2_rel_impl ℱ Rs r1) (rr2_of_rr2_rel_impl ℱ Rs r2)"
| "rr2_of_rr2_rel_impl ℱ Rs (R2Diff r1 r2) = liftO2 (λ x y. simplify_reg (difference_reg x y)) (rr2_of_rr2_rel_impl ℱ Rs r1) (rr2_of_rr2_rel_impl ℱ Rs r2)"
| "rr2_of_rr2_rel_impl ℱ Rs (R2Comp r1 r2) = liftO2 (λ x y. simplify_reg (rr2_compositon ℱ x y))
     (rr2_of_rr2_rel_impl ℱ Rs r1) (rr2_of_rr2_rel_impl ℱ Rs r2)"

lemmas ta_simp_unfold = simplify_reg_def relabel_reg_def trim_reg_def relabel_ta_def term_reg_def
lemma is_ta_eps_free_trim_reg [intro!]:
  "is_ta_eps_free (ta R) ⟹ is_ta_eps_free (ta (trim_reg R))"
  by (simp add: is_ta_eps_free_def trim_reg_def trim_ta_def ta_restrict_def)

lemma is_ta_eps_free_relabel_reg [intro!]:
  "is_ta_eps_free (ta R) ⟹ is_ta_eps_free (ta (relabel_reg R))"
  by (simp add: is_ta_eps_free_def relabel_reg_def relabel_ta_def fmap_states_ta_def)

lemma is_ta_eps_free_simplify_reg [intro!]:
  "is_ta_eps_free (ta R) ⟹ is_ta_eps_free (ta (simplify_reg R))"
  by (simp add: is_ta_eps_free_def ta_simp_unfold fmap_states_ta_def trim_ta_def ta_restrict_def)

lemma is_ta_emptyI [simp]:
 "is_ta_eps_free (TA R {||}) ⟷ True"
  by (simp add: is_ta_eps_free_def)

lemma is_ta_empty_trim_reg:
  "is_ta_eps_free (ta A) ⟹ eps (ta (trim_reg A)) = {||}"
  by (auto simp: is_ta_eps_free_def trim_reg_def trim_ta_def ta_restrict_def)

lemma is_proj_ta_eps_empty:
  "is_ta_eps_free (ta R) ⟹ is_ta_eps_free (ta (proj_1_reg R))"
  "is_ta_eps_free (ta R) ⟹ is_ta_eps_free (ta (proj_2_reg R))"
  by (auto simp: is_ta_eps_free_def proj_1_reg_def proj_2_reg_def collapse_automaton_reg_def collapse_automaton_def
    fmap_funs_reg_def fmap_funs_ta_def trim_reg_def trim_ta_def ta_restrict_def)

lemma is_pod_ta_eps_empty:
  "is_ta_eps_free (ta R) ⟹ is_ta_eps_free (ta L) ⟹ is_ta_eps_free (ta (reg_intersect R L))"
  by (auto simp: reg_intersect_def prod_ta_def prod_epsRp_def prod_epsLp_def is_ta_eps_free_def)

lemma is_fmap_funs_reg_eps_empty:
  "is_ta_eps_free (ta R) ⟹  is_ta_eps_free (ta (fmap_funs_reg f R))"
  by (auto simp: fmap_funs_reg_def fmap_funs_ta_def is_ta_eps_free_def)

lemma is_collapse_automaton_reg_eps_empty:
  "is_ta_eps_free (ta R) ⟹  is_ta_eps_free (ta (collapse_automaton_reg R))"
  by (auto simp: collapse_automaton_reg_def collapse_automaton_def is_ta_eps_free_def)

lemma is_pair_automaton_reg_eps_empty:
  "is_ta_eps_free (ta R) ⟹ is_ta_eps_free (ta L) ⟹ is_ta_eps_free (ta (pair_automaton_reg R L))"
  by (auto simp: pair_automaton_reg_def pair_automaton_def is_ta_eps_free_def)

lemma is_reflcl_automaton_eps_free:
  "is_ta_eps_free A ⟹ is_ta_eps_free (reflcl_automaton (lift_sig_RR2 |`| ℱ) A)"
  by (auto simp: is_ta_eps_free_def reflcl_automaton_def ta_union_def gen_reflcl_automaton_def Let_def fmap_states_ta_def)

lemma is_GTT_to_RR2_root_eps_empty:
  "is_gtt_eps_free 𝒢 ⟹ is_ta_eps_free (GTT_to_RR2_root 𝒢)"
  by (auto simp: is_gtt_eps_free_def GTT_to_RR2_root_def pair_automaton_def is_ta_eps_free_def)

lemma is_term_automata_eps_empty:
  "is_ta_eps_free (ta (term_reg ℱ)) ⟷ True"
  by (auto simp: is_ta_eps_free_def term_reg_def term_automaton_def)

lemma is_ta_eps_free_eps_free_automata [simp]:
  " is_ta_eps_free (eps_free_automata S R) ⟷ True"
  by (auto simp: eps_free_automata_def is_ta_eps_free_def)

lemma rr2_of_rr2_rel_impl_eps_free:
  shows "∀ A. rr1_of_rr1_rel_impl ℱ Rs r1 = Some A ⟶ is_ta_eps_free (ta A)"
   "∀ A. rr2_of_rr2_rel_impl ℱ Rs r2 = Some A ⟶ is_ta_eps_free (ta A)"
proof (induct r1 and r2)
case R1Terms
  then show ?case
    by (auto simp: is_ta_eps_free_def term_automaton_def fmap_states_ta_def ta_simp_unfold)
next
  case (R1NF x)
  then show ?case
    by (auto simp: nf_reg_def nf_ta_def)
next
  case (R1Inf x)
  then show ?case
    by (auto simp: Inf_reg_impl_def Let_def Inf_reg_def Inf_automata_def is_ta_empty_trim_reg intro!: is_proj_ta_eps_empty)
next
  case (R1Proj n x2)
  then show ?case
    by (cases n) (auto  intro!: is_proj_ta_eps_empty)
next
  case (R1Union x1 x2)
  then show ?case
    by (simp add: reg_union_def ta_union_def fmap_states_ta_def is_ta_eps_free_def relabel_reg_def relabel_ta_def)
next
  case (R1Inter x1 x2)
  then show ?case
    by (auto intro: is_pod_ta_eps_empty)
next
  case (R1Diff x1 x2)
  then show ?case
    by (auto simp: difference_reg_def Let_def complement_reg_def ps_reg_def ps_ta_def intro!: is_pod_ta_eps_empty)
next
  case (R2GTT_Rel x1 x2 x3)
  then show ?case 
    by (cases x2; cases x3) (auto simp: GTT_to_RR2_root_reg_def ftrancl_eps_free_closures_def
      eps_free_nhole_mctxt_closure_reg_def eps_free_nhole_mctxt_reflcl_reg_def Let_def
      eps_free_mctxt_closure_reg_def reflcl_reg_def
      dest: gtt_of_gtt_rel_impl_is_gtt_eps_free
      intro!: is_GTT_to_RR2_root_eps_empty is_reflcl_automaton_eps_free)
next
  case (R2Diag x)
  then show ?case by (auto simp: fmap_funs_reg_def fmap_funs_ta_def is_ta_eps_free_def)
next
  case (R2Prod x1 x2)
  then show ?case by (auto intro: is_pair_automaton_reg_eps_empty)
next
  case (R2Inv x)
  then show ?case by (auto simp: fmap_funs_reg_def fmap_funs_ta_def is_ta_eps_free_def)
next
  case (R2Union x1 x2)
  then show ?case by (simp add: reg_union_def ta_union_def fmap_states_ta_def is_ta_eps_free_def relabel_reg_def relabel_ta_def)
next
  case (R2Inter x1 x2)
  then show ?case by (auto intro: is_pod_ta_eps_empty)
next
  case (R2Diff x1 x2)
  then show ?case by (auto simp: difference_reg_def Let_def complement_reg_def ps_reg_def ps_ta_def intro!: is_pod_ta_eps_empty)
next
  case (R2Comp x1 x2)
  then show ?case by (auto simp: is_term_automata_eps_empty rr2_compositon_def Let_def
     intro!: is_pod_ta_eps_empty is_fmap_funs_reg_eps_empty is_collapse_automaton_reg_eps_empty is_pair_automaton_reg_eps_empty)
qed

lemma rr_of_rr_rel_impl_complete:
  "rr1_of_rr1_rel_impl ℱ Rs r1 ≠ None ⟷ rr1_of_rr1_rel ℱ Rs r1 ≠ None"
  "rr2_of_rr2_rel_impl ℱ Rs r2 ≠ None ⟷ rr2_of_rr2_rel ℱ Rs r2 ≠ None"
proof (induct r1 and r2)
  case (R1Proj n x2)
  then show ?case by (cases n) auto
next
  case (R2GTT_Rel x1 n p)
  then show ?case using gtt_of_gtt_rel_impl_gtt_of_gtt_rel[of ℱ Rs]
    by (cases p; cases n) auto
qed auto

lemma 𝒬_fmap_funs_reg [simp]:
  "𝒬r (fmap_funs_reg f 𝒜) = 𝒬r 𝒜"
  by (auto simp: fmap_funs_reg_def)

lemma ta_reachable_fmap_funs_reg [simp]:
  "ta_reachable (ta (fmap_funs_reg f 𝒜)) = ta_reachable (ta 𝒜)"
  by (auto simp: fmap_funs_reg_def)

lemma collapse_reg_cong:
  "𝒬r 𝒜 |⊆| ta_reachable (ta 𝒜) ⟹ 𝒬r ℬ |⊆| ta_reachable (ta ℬ) ⟹ ℒ 𝒜 = ℒ ℬ ⟹ ℒ (collapse_automaton_reg 𝒜) = ℒ (collapse_automaton_reg ℬ)"
  by (auto simp: collapse_automaton_reg_def ℒ_def collapse_automaton')

lemma ℒ_fmap_funs_reg_cong:
  "ℒ 𝒜 = ℒ ℬ ⟹ ℒ (fmap_funs_reg h 𝒜) = ℒ (fmap_funs_reg h ℬ)"
  by (auto simp: fmap_funs_ℒ)

lemma ℒ_pair_automaton_reg_cong:
  "ℒ 𝒜 = ℒ ℬ ⟹ ℒ 𝒞 = ℒ 𝒟 ⟹ ℒ (pair_automaton_reg 𝒜 𝒞) = ℒ (pair_automaton_reg ℬ 𝒟)"
  by (auto simp: pair_automaton')

lemma ℒ_nhole_ctxt_closure_reg_cong:
  "ℒ 𝒜 = ℒ ℬ ⟹ ℱ = 𝒢 ⟹ ℒ (nhole_ctxt_closure_reg ℱ 𝒜) = ℒ (nhole_ctxt_closure_reg 𝒢 ℬ)"
  by (auto simp: nhole_ctxtcl_lang)

lemma ℒ_nhole_mctxt_closure_reg_cong:
  "ℒ 𝒜 = ℒ ℬ ⟹ ℱ = 𝒢 ⟹ ℒ (nhole_mctxt_closure_reg ℱ 𝒜) = ℒ (nhole_mctxt_closure_reg 𝒢 ℬ)"
  by (auto simp: nhole_gmctxt_closure_lang)

lemma ℒ_ctxt_closure_reg_cong:
  "ℒ 𝒜 = ℒ ℬ ⟹ ℱ = 𝒢 ⟹ ℒ (ctxt_closure_reg ℱ 𝒜) = ℒ (ctxt_closure_reg 𝒢 ℬ)"
  by (auto simp: gctxt_closure_lang)

lemma ℒ_parallel_closure_reg_cong:
  "ℒ 𝒜 = ℒ ℬ ⟹ ℱ = 𝒢 ⟹ ℒ (parallel_closure_reg ℱ 𝒜) = ℒ (parallel_closure_reg 𝒢 ℬ)"
  by (auto simp: parallelcl_gmctxt_lang)

lemma ℒ_mctxt_closure_reg_cong:
  "ℒ 𝒜 = ℒ ℬ ⟹ ℱ = 𝒢 ⟹ ℒ (mctxt_closure_reg ℱ 𝒜) = ℒ (mctxt_closure_reg 𝒢 ℬ)"
  by (auto simp: gmctxt_closure_lang)

lemma ℒ_nhole_mctxt_reflcl_reg_cong:
  "ℒ 𝒜 = ℒ ℬ ⟹ ℱ = 𝒢 ⟹ ℒ (nhole_mctxt_reflcl_reg ℱ 𝒜) = ℒ (nhole_mctxt_reflcl_reg 𝒢 ℬ)"
  unfolding nhole_mctxt_reflcl_lang
  by (intro arg_cong2[where ?f = "(∪)"] ℒ_nhole_mctxt_closure_reg_cong) auto

declare equalityI[rule del]
declare fsubsetI[rule del]
lemma ℒ_proj_1_reg_cong:
  "ℒ 𝒜 = ℒ ℬ ⟹ ℒ (proj_1_reg 𝒜) = ℒ (proj_1_reg ℬ)"
  by (auto simp: proj_1_reg_def ℒ_trim intro!: collapse_reg_cong ℒ_fmap_funs_reg_cong)

lemma ℒ_proj_2_reg_cong:
  "ℒ 𝒜 = ℒ ℬ ⟹ ℒ (proj_2_reg 𝒜) = ℒ (proj_2_reg ℬ)"
  by (auto simp: proj_2_reg_def ℒ_trim intro!: collapse_reg_cong ℒ_fmap_funs_reg_cong)

lemma rr2_of_rr2_rel_impl_sound:
  assumes  "∀R ∈ set Rs. lv_trs (fset R) ∧ ffunas_trs R |⊆| ℱ"
  shows "⋀ A B. rr1_of_rr1_rel_impl ℱ Rs r1 = Some A ⟹ rr1_of_rr1_rel ℱ Rs r1 = Some B ⟹ ℒ A = ℒ B"
  "⋀ A B. rr2_of_rr2_rel_impl ℱ Rs r2 = Some A ⟹ rr2_of_rr2_rel ℱ Rs r2 = Some B ⟹ ℒ A = ℒ B"
proof (induct r1 and r2)
  case (R1Inf r)
  then obtain C D where inf: "rr2_of_rr2_rel_impl ℱ Rs r = Some C" "rr2_of_rr2_rel ℱ Rs r = Some D"
     "ℒ C = ℒ D" by auto
  have spec: "RR2_spec C (eval_rr2_rel (fset ℱ) (map fset Rs) r)" "RR2_spec D (eval_rr2_rel (fset ℱ) (map fset Rs) r)"
    using rr12_of_rr12_rel_correct(2)[OF assms, rule_format, OF inf(2)] inf(3)
    by (auto simp: RR2_spec_def)
  then have trim_spec: "RR2_spec (trim_reg C) (eval_rr2_rel (fset ℱ) (map fset Rs) r)"
    "RR2_spec (trim_reg D) (eval_rr2_rel (fset ℱ) (map fset Rs) r)"
    by (auto simp: RR2_spec_def ℒ_trim)
  let ?C = "Inf_reg (trim_reg C) (Q_infty (ta (trim_reg C)) ℱ)" let ?D = "Inf_reg (trim_reg D) (Q_infty (ta (trim_reg D)) ℱ)" 
  from spec have *: "ℒ (Inf_reg_impl (trim_reg C)) = ℒ ?C"
    using eval_rr12_rel_sig(2)[of "fset ℱ" "map fset Rs" r]
    by (intro Inf_reg_impl_sound) (auto simp: RR2_spec_def ℒ_trim 𝒯G_equivalent_def)
  from spec have **: "ℒ (Inf_reg_impl (trim_reg D)) = ℒ ?D"
    using eval_rr12_rel_sig(2)[of "fset ℱ" "map fset Rs" r]
    by (intro Inf_reg_impl_sound) (auto simp: RR2_spec_def ℒ_trim 𝒯G_equivalent_def)
  then have C: "RR2_spec ?C {(s, t) | s t. gpair s t ∈ ℒ ?C}" and
    D: "RR2_spec ?D {(s, t) | s t. gpair s t ∈ ℒ ?D}"
    using subset_trans[OF Inf_automata_subseteq[of "trim_reg C" ℱ], of "ℒ C"] spec
    using subset_trans[OF Inf_automata_subseteq[of "trim_reg D" ℱ], of "ℒ D"]
    using eval_rr12_rel_sig(2)[of "fset ℱ" "map fset Rs" r]
    by (auto simp: RR2_spec_def ℒ_trim 𝒯G_equivalent_def intro!: equalityI fsubsetI)
  from * ** have r: "ℒ (proj_1_reg (Inf_reg_impl (trim_reg C))) = ℒ (proj_1_reg ?C)"
    "ℒ (proj_1_reg (Inf_reg_impl (trim_reg D))) = ℒ (proj_1_reg ?D)"
    by (auto intro: ℒ_proj_1_reg_cong)
  from ℒ_Inf_reg[OF trim_spec(1), of ℱ] ℒ_Inf_reg[OF trim_spec(2), of ℱ]
  show ?case using R1Inf eval_rr12_rel_sig(2)[of "fset ℱ" "map fset Rs" r]
    by (auto simp: liftO1_def r inf 𝒯G_equivalent_def ℒ_proj(1)[OF C] ℒ_proj(1)[OF D])
next
  case (R1Proj n x2)
  then show ?case by (cases n)
    (auto simp: liftO1_def ℒ_trim proj_1_reg_def proj_2_reg_def intro!: fsubsetI ℒ_fmap_funs_reg_cong collapse_reg_cong, (meson fin_mono trim_reg_reach)+)
next
  case (R2GTT_Rel g p n) note IH = this
  note ass = R2GTT_Rel
  consider (a) "∃ A. gtt_of_gtt_rel_impl ℱ Rs g = Some A" | (b) "gtt_of_gtt_rel_impl ℱ Rs g = None" by blast
  then show ?case
  proof cases
    case a then obtain C D where gtt [simp]: "gtt_of_gtt_rel_impl ℱ Rs g = Some C"
      "gtt_of_gtt_rel ℱ Rs g = Some D" using gtt_of_gtt_rel_impl_gtt_of_gtt_rel by blast
    from gtt_of_gtt_rel_impl_sound[OF this]
    have spec [simp]: "agtt_lang C = agtt_lang D" by auto
    have eps [simp]: "is_ta_eps_free (ta (GTT_to_RR2_root_reg C))"
      using gtt_of_gtt_rel_impl_is_gtt_eps_free[OF gtt(1)]
      by (auto simp: GTT_to_RR2_root_reg_def GTT_to_RR2_root_def pair_automaton_def is_ta_eps_free_def is_gtt_eps_free_def)
    have lang: "ℒ (GTT_to_RR2_root_reg C) = ℒ (GTT_to_RR2_root_reg D)"
      by (metis (no_types, lifting) GTT_to_RR2_root RR2_spec_def spec)
    show ?thesis
    proof (cases p)
      case PRoot
      then show ?thesis using IH spec lang
        by (cases n) (auto simp: ℒ_eps_free ℒ_reflcl_reg)
    next
      case PNonRoot
      then show ?thesis using IH
        by (cases n) (auto simp: ℒ_eps_free ℒ_eps_free_nhole_ctxt_closure_reg[OF eps]
        ℒ_eps_free_nhole_mctxt_reflcl_reg[OF eps] ℒ_eps_free_nhole_mctxt_closure_reg[OF eps]
        lang intro: ℒ_nhole_ctxt_closure_reg_cong ℒ_nhole_mctxt_reflcl_reg_cong ℒ_nhole_mctxt_closure_reg_cong)
    next
      case PAny
      then show ?thesis using IH
        by (cases n) (auto simp: ℒ_eps_free ℒ_eps_free_ctxt_closure_reg[OF eps]
          ℒ_eps_free_parallel_closure_reg[OF eps] ℒ_eps_free_mctxt_closure_reg[OF eps] lang
          intro!: ℒ_ctxt_closure_reg_cong ℒ_parallel_closure_reg_cong ℒ_mctxt_closure_reg_cong)
    qed
  next
    case b then show ?thesis using IH
      by (cases p; cases n) auto
  qed
next
  case (R2Comp x1 x2)
  then show ?case
    by (auto simp: liftO1_def rr2_compositon_def ℒ_trim ℒ_intersect Let_def
        intro!: ℒ_pair_automaton_reg_cong ℒ_fmap_funs_reg_cong collapse_reg_cong arg_cong2[where ?f = "(∩)"])
qed (auto simp: liftO1_def ℒ_intersect ℒ_union ℒ_trim ℒ_difference_reg intro!: ℒ_fmap_funs_reg_cong ℒ_pair_automaton_reg_cong)
declare equalityI[intro!]
declare fsubsetI[intro!]

lemma rr12_of_rr12_rel_impl_correct:
  assumes  "∀R ∈ set Rs. lv_trs (fset R) ∧ ffunas_trs R |⊆| ℱ"
  shows "∀ta1. rr1_of_rr1_rel_impl ℱ Rs r1 = Some ta1 ⟶ RR1_spec ta1 (eval_rr1_rel (fset ℱ) (map fset Rs) r1)"
    "∀ta2. rr2_of_rr2_rel_impl ℱ Rs r2 = Some ta2 ⟶ RR2_spec ta2 (eval_rr2_rel (fset ℱ) (map fset Rs) r2)"
  using rr12_of_rr12_rel_correct(1)[OF assms, of r1]
  using rr12_of_rr12_rel_correct(2)[OF assms, of r2]
  using rr2_of_rr2_rel_impl_sound(1)[OF assms, of r1]
  using rr2_of_rr2_rel_impl_sound(2)[OF assms, of r2]
  using rr_of_rr_rel_impl_complete(1)[of ℱ Rs r1]
  using rr_of_rr_rel_impl_complete(2)[of ℱ Rs r2]
  by (force simp: RR1_spec_def RR2_spec_def)+

lemma check_inference_rrn_impl_correct:
  assumes sig: "𝒯G (fset ℱ) ≠ {}" and Rs: "∀R ∈ set Rs. lv_trs (fset R) ∧ ffunas_trs R |⊆| ℱ"
  assumes infs: "⋀fvA. fvA ∈ set infs ⟹ formula_spec (fset ℱ) (map fset Rs) (fst (snd fvA)) (snd (snd fvA)) (fst fvA)"
  assumes inf: "check_inference rr1_of_rr1_rel_impl rr2_of_rr2_rel_impl ℱ Rs infs (l, step, fm, is) = Some (fm', vs, A')"
  shows "l = length infs ∧ fm = fm' ∧ formula_spec (fset ℱ) (map fset Rs) vs A' fm'"
  using check_inference_correct[where ?rr1c = rr1_of_rr1_rel_impl and ?rr2c = rr2_of_rr2_rel_impl, OF assms]
  using rr12_of_rr12_rel_impl_correct[OF Rs]
  by auto

definition check_sig_nempty where
  "check_sig_nempty ℱ = (0 |∈| snd |`| ℱ)"

definition check_trss where
  "check_trss ℛ ℱ = list_all (λ R. lv_trs (fset R) ∧ funas_trs (fset R) ⊆ fset ℱ) ℛ"

lemma check_sig_nempty:
  "check_sig_nempty ℱ ⟷ 𝒯G (fset ℱ) ≠ {}" (is "?Ls ⟷ ?Rs")
proof -
  {assume ?Ls then obtain a where "(a, 0) |∈| ℱ" by (auto simp: check_sig_nempty_def)
    then have "GFun a [] ∈ 𝒯G (fset ℱ)"
      by (intro const) (simp add: fmember.rep_eq)
    then have ?Rs by blast}
  moreover
  {assume ?Rs then obtain s where "s ∈ 𝒯G (fset ℱ)" by blast
    then obtain a where "(a, 0) |∈| ℱ" unfolding fmember.rep_eq
      by (induct s) (auto, force)
    then have ?Ls unfolding check_sig_nempty_def
      by (auto simp: fimage_iff fBex_def)}
  ultimately show ?thesis by blast
qed

lemma check_trss:
  "check_trss ℛ ℱ ⟷ (∀ R ∈ set ℛ. lv_trs (fset R) ∧ ffunas_trs R |⊆| ℱ)"
  unfolding check_trss_def list_all_iff
  by (auto simp: fmember.rep_eq ffunas_trs.rep_eq less_eq_fset.rep_eq)

fun check_inference_list :: "('f × nat) fset ⇒ ('f ::  {compare,linorder}, 'v) fin_trs list
  ⇒ (nat × ftrs inference × ftrs formula × info list) list
  ⇒ (ftrs formula × nat list × (nat, 'f option list) reg) list option" where
  "check_inference_list ℱ Rs infs = do {
     guard (check_sig_nempty ℱ);
     guard (check_trss Rs ℱ);
     foldl (λ tas inf. do {
        tas' ← tas;
        r ← check_inference rr1_of_rr1_rel_impl rr2_of_rr2_rel_impl ℱ Rs tas' inf;
        Some (tas' @ [r])
      })
      (Some []) infs
  }"

lemma check_inference_list_correct:
  assumes "check_inference_list ℱ Rs infs = Some fvAs"
  shows "length infs = length fvAs ∧ (∀ i < length fvAs. fst (snd (snd (infs ! i))) = fst (fvAs ! i)) ∧
   (∀ i < length fvAs. formula_spec (fset ℱ) (map fset Rs) (fst (snd (fvAs ! i))) (snd (snd (fvAs ! i))) (fst (fvAs ! i)))"
  using assms
proof (induct infs arbitrary: fvAs rule: rev_induct)
  note [simp] = bind_eq_Some_conv guard_simps
  {case Nil
    then show ?case by auto
  next
    case (snoc a infs)
    have inv: "𝒯G (fset ℱ) ≠ {}" "∀R∈set Rs. lv_trs (fset R) ∧ ffunas_trs R |⊆| ℱ"
      using snoc(2) by (auto simp: check_sig_nempty check_trss)
    from snoc(2) obtain fvAs' l steps fm fm' is' vs A' where
      ch: "check_inference_list ℱ Rs infs = Some fvAs'" "a = (l, steps, fm, is')"
      "check_inference rr1_of_rr1_rel_impl rr2_of_rr2_rel_impl ℱ Rs fvAs' (l, steps, fm, is') = Some (fm', vs, A')" "fvAs = fvAs' @ [(fm', vs, A')]"
      by (auto simp del: check_inference.simps) (metis prod_cases4)
    from snoc(1)[OF ch(1)] have "fvA ∈ set fvAs' ⟹ formula_spec (fset ℱ) (map fset Rs) (fst (snd fvA)) (snd (snd fvA)) (fst fvA)" for fvA
      by (auto dest: in_set_idx)
    from check_inference_rrn_impl_correct[OF inv this, of fvAs'] this
    show ?case using snoc(1)[OF ch(1)] ch
      by (auto simp del: check_inference.simps simp: nth_append)
  }
qed

fun check_certificate where
  "check_certificate ℱ Rs A fm (Certificate infs claim n) = do {
    guard (n < length infs);
    guard (A ⟷ claim = Nonempty);
    guard (fm = fst (snd (snd (infs ! n))));
    fvA ← check_inference_list ℱ Rs (take (Suc n) infs);
    (let E = reg_empty (snd (snd (last fvA))) in
     case claim of Empty ⇒ Some E
       | _ ⇒ Some (¬ E))
  }"

definition formula_unsatisfiable where
  "formula_unsatisfiable ℱ Rs fm ⟷ (formula_satisfiable ℱ Rs fm = False)"

definition correct_certificate where
  "correct_certificate ℱ Rs claim infs n ≡
    (claim = Empty ⟷ (formula_unsatisfiable (fset ℱ) (map fset Rs) (fst (snd (snd (infs ! n))))) ∧
     claim = Nonempty ⟷ formula_satisfiable (fset ℱ) (map fset Rs) (fst (snd (snd (infs ! n)))))"

lemma check_certificate_sound:
  assumes "check_certificate ℱ Rs A fm (Certificate infs claim n) = Some B"
  shows "fm = fst (snd (snd (infs ! n)))" "A ⟷ claim = Nonempty"
  using assms by (auto simp: bind_eq_Some_conv guard_simps)

lemma check_certificate_correct:
  assumes "check_certificate ℱ Rs A fm (Certificate infs claim n) = Some B"
  shows "(B = True ⟶ correct_certificate ℱ Rs claim infs n) ∧
    (B = False ⟶ correct_certificate ℱ Rs (case_claim Nonempty Empty claim) infs n)"
proof -
  note [simp] = bind_eq_Some_conv guard_simps
  from assms obtain fvAs where inf: "check_inference_list ℱ Rs (take (Suc n) infs) = Some fvAs"
    by auto
  from assms have len: "n < length infs" by auto
  from check_inference_list_correct[OF inf] have
    inv: "length fvAs = n + 1"
    "fst (snd (snd (infs ! n))) = fst (fvAs ! n)"
    "formula_spec (fset ℱ) (map fset Rs) (fst (snd (last fvAs))) (snd (snd (last fvAs))) (fst (last fvAs))"
    using len last_conv_nth[of fvAs] by force+
  have nth: "fst (last fvAs) = fst (fvAs ! n)" using inv(1)
    using len last_conv_nth[of fvAs] by force
  note spec = formula_spec_empty[OF _ inv(3)] formula_spec_nt_empty_form_sat[OF _ inv(3)]
  consider (a) "claim = Empty" | (b) "claim = Nonempty" using claim.exhaust by blast
  then show ?thesis
  proof cases
    case a
    then have *: "B = reg_empty (snd (snd (last fvAs)))" using inv
      using assms len last_conv_nth[of fvAs]
      by (auto simp: inf simp del: check_inference_list.simps)
    show ?thesis using a inv spec unfolding *
      by (auto simp: formula_satisfiable_def nth correct_certificate_def formula_unsatisfiable_def simp del: reg_empty)
  next
    case b
    then have *: "B ⟷ ¬ (reg_empty (snd (snd (last fvAs))))" using inv
      using assms len last_conv_nth[of fvAs]
      by (auto simp: inf simp del: check_inference_list.simps)
    show ?thesis using b inv spec unfolding *
      by (auto simp: formula_satisfiable_def nth formula_unsatisfiable_def correct_certificate_def simp del: reg_empty)
  qed
qed


definition check_certificate_string ::
  "(integer list × fvar) fset ⇒
   ((integer list, integer list) Term.term × (integer list, integer list) Term.term) fset list ⇒
   bool ⇒ ftrs formula ⇒ ftrs certificate ⇒ bool option"
  where "check_certificate_string = check_certificate"


(***********************************)
export_code check_certificate_string Var Fun fset_of_list nat_of_integer Certificate
  R2GTT_Rel R2Eq R2Reflc R2Step R2StepEq R2Steps R2StepsEq R2StepsNF R2ParStep R2RootStep
  R2RootStepEq R2RootSteps R2RootStepsEq R2NonRootStep R2NonRootStepEq R2NonRootSteps
  R2NonRootStepsEq R2Meet R2Join
  ARoot GSteps PRoot ESingle Empty Size EDistribAndOr
  R1Terms R1Fin
  FRR1 FRestrict FTrue FFalse
  IRR1 Fwd in Haskell module_name FOR

end